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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 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 Exp_Disp; use Exp_Disp; 34with Fname; use Fname; 35with Fname.UF; use Fname.UF; 36with Freeze; use Freeze; 37with Ghost; use Ghost; 38with Itypes; use Itypes; 39with Lib; use Lib; 40with Lib.Load; use Lib.Load; 41with Lib.Xref; use Lib.Xref; 42with Nlists; use Nlists; 43with Namet; use Namet; 44with Nmake; use Nmake; 45with Opt; use Opt; 46with Rident; use Rident; 47with Restrict; use Restrict; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch3; use Sem_Ch3; 53with Sem_Ch6; use Sem_Ch6; 54with Sem_Ch7; use Sem_Ch7; 55with Sem_Ch8; use Sem_Ch8; 56with Sem_Ch10; use Sem_Ch10; 57with Sem_Ch13; use Sem_Ch13; 58with Sem_Dim; use Sem_Dim; 59with Sem_Disp; use Sem_Disp; 60with Sem_Elab; use Sem_Elab; 61with Sem_Elim; use Sem_Elim; 62with Sem_Eval; use Sem_Eval; 63with Sem_Prag; use Sem_Prag; 64with Sem_Res; use Sem_Res; 65with Sem_Type; use Sem_Type; 66with Sem_Util; use Sem_Util; 67with Sem_Warn; use Sem_Warn; 68with Stand; use Stand; 69with Sinfo; use Sinfo; 70with Sinfo.CN; use Sinfo.CN; 71with Sinput; use Sinput; 72with Sinput.L; use Sinput.L; 73with Snames; use Snames; 74with Stringt; use Stringt; 75with Uname; use Uname; 76with Table; 77with Tbuild; use Tbuild; 78with Uintp; use Uintp; 79with Urealp; use Urealp; 80with Warnsw; use Warnsw; 81 82with GNAT.HTable; 83 84package body Sem_Ch12 is 85 86 ---------------------------------------------------------- 87 -- Implementation of Generic Analysis and Instantiation -- 88 ---------------------------------------------------------- 89 90 -- GNAT implements generics by macro expansion. No attempt is made to share 91 -- generic instantiations (for now). Analysis of a generic definition does 92 -- not perform any expansion action, but the expander must be called on the 93 -- tree for each instantiation, because the expansion may of course depend 94 -- on the generic actuals. All of this is best achieved as follows: 95 -- 96 -- a) Semantic analysis of a generic unit is performed on a copy of the 97 -- tree for the generic unit. All tree modifications that follow analysis 98 -- do not affect the original tree. Links are kept between the original 99 -- tree and the copy, in order to recognize non-local references within 100 -- the generic, and propagate them to each instance (recall that name 101 -- resolution is done on the generic declaration: generics are not really 102 -- macros). This is summarized in the following diagram: 103 104 -- .-----------. .----------. 105 -- | semantic |<--------------| generic | 106 -- | copy | | unit | 107 -- | |==============>| | 108 -- |___________| global |__________| 109 -- references | | | 110 -- | | | 111 -- .-----|--|. 112 -- | .-----|---. 113 -- | | .----------. 114 -- | | | generic | 115 -- |__| | | 116 -- |__| instance | 117 -- |__________| 118 119 -- b) Each instantiation copies the original tree, and inserts into it a 120 -- series of declarations that describe the mapping between generic formals 121 -- and actuals. For example, a generic In OUT parameter is an object 122 -- renaming of the corresponding actual, etc. Generic IN parameters are 123 -- constant declarations. 124 125 -- c) In order to give the right visibility for these renamings, we use 126 -- a different scheme for package and subprogram instantiations. For 127 -- packages, the list of renamings is inserted into the package 128 -- specification, before the visible declarations of the package. The 129 -- renamings are analyzed before any of the text of the instance, and are 130 -- thus visible at the right place. Furthermore, outside of the instance, 131 -- the generic parameters are visible and denote their corresponding 132 -- actuals. 133 134 -- For subprograms, we create a container package to hold the renamings 135 -- and the subprogram instance itself. Analysis of the package makes the 136 -- renaming declarations visible to the subprogram. After analyzing the 137 -- package, the defining entity for the subprogram is touched-up so that 138 -- it appears declared in the current scope, and not inside the container 139 -- package. 140 141 -- If the instantiation is a compilation unit, the container package is 142 -- given the same name as the subprogram instance. This ensures that 143 -- the elaboration procedure called by the binder, using the compilation 144 -- unit name, calls in fact the elaboration procedure for the package. 145 146 -- Not surprisingly, private types complicate this approach. By saving in 147 -- the original generic object the non-local references, we guarantee that 148 -- the proper entities are referenced at the point of instantiation. 149 -- However, for private types, this by itself does not insure that the 150 -- proper VIEW of the entity is used (the full type may be visible at the 151 -- point of generic definition, but not at instantiation, or vice-versa). 152 -- In order to reference the proper view, we special-case any reference 153 -- to private types in the generic object, by saving both views, one in 154 -- the generic and one in the semantic copy. At time of instantiation, we 155 -- check whether the two views are consistent, and exchange declarations if 156 -- necessary, in order to restore the correct visibility. Similarly, if 157 -- the instance view is private when the generic view was not, we perform 158 -- the exchange. After completing the instantiation, we restore the 159 -- current visibility. The flag Has_Private_View marks identifiers in the 160 -- the generic unit that require checking. 161 162 -- Visibility within nested generic units requires special handling. 163 -- Consider the following scheme: 164 165 -- type Global is ... -- outside of generic unit. 166 -- generic ... 167 -- package Outer is 168 -- ... 169 -- type Semi_Global is ... -- global to inner. 170 171 -- generic ... -- 1 172 -- procedure inner (X1 : Global; X2 : Semi_Global); 173 174 -- procedure in2 is new inner (...); -- 4 175 -- end Outer; 176 177 -- package New_Outer is new Outer (...); -- 2 178 -- procedure New_Inner is new New_Outer.Inner (...); -- 3 179 180 -- The semantic analysis of Outer captures all occurrences of Global. 181 -- The semantic analysis of Inner (at 1) captures both occurrences of 182 -- Global and Semi_Global. 183 184 -- At point 2 (instantiation of Outer), we also produce a generic copy 185 -- of Inner, even though Inner is, at that point, not being instantiated. 186 -- (This is just part of the semantic analysis of New_Outer). 187 188 -- Critically, references to Global within Inner must be preserved, while 189 -- references to Semi_Global should not preserved, because they must now 190 -- resolve to an entity within New_Outer. To distinguish between these, we 191 -- use a global variable, Current_Instantiated_Parent, which is set when 192 -- performing a generic copy during instantiation (at 2). This variable is 193 -- used when performing a generic copy that is not an instantiation, but 194 -- that is nested within one, as the occurrence of 1 within 2. The analysis 195 -- of a nested generic only preserves references that are global to the 196 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to 197 -- determine whether a reference is external to the given parent. 198 199 -- The instantiation at point 3 requires no special treatment. The method 200 -- works as well for further nestings of generic units, but of course the 201 -- variable Current_Instantiated_Parent must be stacked because nested 202 -- instantiations can occur, e.g. the occurrence of 4 within 2. 203 204 -- The instantiation of package and subprogram bodies is handled in a 205 -- similar manner, except that it is delayed until after semantic 206 -- analysis is complete. In this fashion complex cross-dependencies 207 -- between several package declarations and bodies containing generics 208 -- can be compiled which otherwise would diagnose spurious circularities. 209 210 -- For example, it is possible to compile two packages A and B that 211 -- have the following structure: 212 213 -- package A is package B is 214 -- generic ... generic ... 215 -- package G_A is package G_B is 216 217 -- with B; with A; 218 -- package body A is package body B is 219 -- package N_B is new G_B (..) package N_A is new G_A (..) 220 221 -- The table Pending_Instantiations in package Inline is used to keep 222 -- track of body instantiations that are delayed in this manner. Inline 223 -- handles the actual calls to do the body instantiations. This activity 224 -- is part of Inline, since the processing occurs at the same point, and 225 -- for essentially the same reason, as the handling of inlined routines. 226 227 ---------------------------------------------- 228 -- Detection of Instantiation Circularities -- 229 ---------------------------------------------- 230 231 -- If we have a chain of instantiations that is circular, this is static 232 -- error which must be detected at compile time. The detection of these 233 -- circularities is carried out at the point that we insert a generic 234 -- instance spec or body. If there is a circularity, then the analysis of 235 -- the offending spec or body will eventually result in trying to load the 236 -- same unit again, and we detect this problem as we analyze the package 237 -- instantiation for the second time. 238 239 -- At least in some cases after we have detected the circularity, we get 240 -- into trouble if we try to keep going. The following flag is set if a 241 -- circularity is detected, and used to abandon compilation after the 242 -- messages have been posted. 243 244 ----------------------------------------- 245 -- Implementation of Generic Contracts -- 246 ----------------------------------------- 247 248 -- A "contract" is a collection of aspects and pragmas that either verify a 249 -- property of a construct at runtime or classify the data flow to and from 250 -- the construct in some fashion. 251 252 -- Generic packages, subprograms and their respective bodies may be subject 253 -- to the following contract-related aspects or pragmas collectively known 254 -- as annotations: 255 256 -- package subprogram [body] 257 -- Abstract_State Contract_Cases 258 -- Initial_Condition Depends 259 -- Initializes Extensions_Visible 260 -- Global 261 -- package body Post 262 -- Refined_State Post_Class 263 -- Postcondition 264 -- Pre 265 -- Pre_Class 266 -- Precondition 267 -- Refined_Depends 268 -- Refined_Global 269 -- Refined_Post 270 -- Test_Case 271 272 -- Most package contract annotations utilize forward references to classify 273 -- data declared within the package [body]. Subprogram annotations then use 274 -- the classifications to further refine them. These inter dependencies are 275 -- problematic with respect to the implementation of generics because their 276 -- analysis, capture of global references and instantiation does not mesh 277 -- well with the existing mechanism. 278 279 -- 1) Analysis of generic contracts is carried out the same way non-generic 280 -- contracts are analyzed: 281 282 -- 1.1) General rule - a contract is analyzed after all related aspects 283 -- and pragmas are analyzed. This is done by routines 284 285 -- Analyze_Package_Body_Contract 286 -- Analyze_Package_Contract 287 -- Analyze_Subprogram_Body_Contract 288 -- Analyze_Subprogram_Contract 289 290 -- 1.2) Compilation unit - the contract is analyzed after Pragmas_After 291 -- are processed. 292 293 -- 1.3) Compilation unit body - the contract is analyzed at the end of 294 -- the body declaration list. 295 296 -- 1.4) Package - the contract is analyzed at the end of the private or 297 -- visible declarations, prior to analyzing the contracts of any nested 298 -- packages or subprograms. 299 300 -- 1.5) Package body - the contract is analyzed at the end of the body 301 -- declaration list, prior to analyzing the contracts of any nested 302 -- packages or subprograms. 303 304 -- 1.6) Subprogram - if the subprogram is declared inside a block, a 305 -- package or a subprogram, then its contract is analyzed at the end of 306 -- the enclosing declarations, otherwise the subprogram is a compilation 307 -- unit 1.2). 308 309 -- 1.7) Subprogram body - if the subprogram body is declared inside a 310 -- block, a package body or a subprogram body, then its contract is 311 -- analyzed at the end of the enclosing declarations, otherwise the 312 -- subprogram is a compilation unit 1.3). 313 314 -- 2) Capture of global references within contracts is done after capturing 315 -- global references within the generic template. There are two reasons for 316 -- this delay - pragma annotations are not part of the generic template in 317 -- the case of a generic subprogram declaration, and analysis of contracts 318 -- is delayed. 319 320 -- Contract-related source pragmas within generic templates are prepared 321 -- for delayed capture of global references by routine 322 323 -- Create_Generic_Contract 324 325 -- The routine associates these pragmas with the contract of the template. 326 -- In the case of a generic subprogram declaration, the routine creates 327 -- generic templates for the pragmas declared after the subprogram because 328 -- they are not part of the template. 329 330 -- generic -- template starts 331 -- procedure Gen_Proc (Input : Integer); -- template ends 332 -- pragma Precondition (Input > 0); -- requires own template 333 334 -- 2.1) The capture of global references with aspect specifications and 335 -- source pragmas that apply to a generic unit must be suppressed when 336 -- the generic template is being processed because the contracts have not 337 -- been analyzed yet. Any attempts to capture global references at that 338 -- point will destroy the Associated_Node linkages and leave the template 339 -- undecorated. This delay is controlled by routine 340 341 -- Requires_Delayed_Save 342 343 -- 2.2) The real capture of global references within a contract is done 344 -- after the contract has been analyzed, by routine 345 346 -- Save_Global_References_In_Contract 347 348 -- 3) The instantiation of a generic contract occurs as part of the 349 -- instantiation of the contract owner. Generic subprogram declarations 350 -- require additional processing when the contract is specified by pragmas 351 -- because the pragmas are not part of the generic template. This is done 352 -- by routine 353 354 -- Instantiate_Subprogram_Contract 355 356 Circularity_Detected : Boolean := False; 357 -- This should really be reset on encountering a new main unit, but in 358 -- practice we are not using multiple main units so it is not critical. 359 360 -------------------------------------------------- 361 -- Formal packages and partial parameterization -- 362 -------------------------------------------------- 363 364 -- When compiling a generic, a formal package is a local instantiation. If 365 -- declared with a box, its generic formals are visible in the enclosing 366 -- generic. If declared with a partial list of actuals, those actuals that 367 -- are defaulted (covered by an Others clause, or given an explicit box 368 -- initialization) are also visible in the enclosing generic, while those 369 -- that have a corresponding actual are not. 370 371 -- In our source model of instantiation, the same visibility must be 372 -- present in the spec and body of an instance: the names of the formals 373 -- that are defaulted must be made visible within the instance, and made 374 -- invisible (hidden) after the instantiation is complete, so that they 375 -- are not accessible outside of the instance. 376 377 -- In a generic, a formal package is treated like a special instantiation. 378 -- Our Ada 95 compiler handled formals with and without box in different 379 -- ways. With partial parameterization, we use a single model for both. 380 -- We create a package declaration that consists of the specification of 381 -- the generic package, and a set of declarations that map the actuals 382 -- into local renamings, just as we do for bona fide instantiations. For 383 -- defaulted parameters and formals with a box, we copy directly the 384 -- declarations of the formal into this local package. The result is a 385 -- a package whose visible declarations may include generic formals. This 386 -- package is only used for type checking and visibility analysis, and 387 -- never reaches the back-end, so it can freely violate the placement 388 -- rules for generic formal declarations. 389 390 -- The list of declarations (renamings and copies of formals) is built 391 -- by Analyze_Associations, just as for regular instantiations. 392 393 -- At the point of instantiation, conformance checking must be applied only 394 -- to those parameters that were specified in the formal. We perform this 395 -- checking by creating another internal instantiation, this one including 396 -- only the renamings and the formals (the rest of the package spec is not 397 -- relevant to conformance checking). We can then traverse two lists: the 398 -- list of actuals in the instance that corresponds to the formal package, 399 -- and the list of actuals produced for this bogus instantiation. We apply 400 -- the conformance rules to those actuals that are not defaulted (i.e. 401 -- which still appear as generic formals. 402 403 -- When we compile an instance body we must make the right parameters 404 -- visible again. The predicate Is_Generic_Formal indicates which of the 405 -- formals should have its Is_Hidden flag reset. 406 407 ----------------------- 408 -- Local subprograms -- 409 ----------------------- 410 411 procedure Abandon_Instantiation (N : Node_Id); 412 pragma No_Return (Abandon_Instantiation); 413 -- Posts an error message "instantiation abandoned" at the indicated node 414 -- and then raises the exception Instantiation_Error to do it. 415 416 procedure Analyze_Formal_Array_Type 417 (T : in out Entity_Id; 418 Def : Node_Id); 419 -- A formal array type is treated like an array type declaration, and 420 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is 421 -- in-out, because in the case of an anonymous type the entity is 422 -- actually created in the procedure. 423 424 -- The following procedures treat other kinds of formal parameters 425 426 procedure Analyze_Formal_Derived_Interface_Type 427 (N : Node_Id; 428 T : Entity_Id; 429 Def : Node_Id); 430 431 procedure Analyze_Formal_Derived_Type 432 (N : Node_Id; 433 T : Entity_Id; 434 Def : Node_Id); 435 436 procedure Analyze_Formal_Interface_Type 437 (N : Node_Id; 438 T : Entity_Id; 439 Def : Node_Id); 440 441 -- The following subprograms create abbreviated declarations for formal 442 -- scalar types. We introduce an anonymous base of the proper class for 443 -- each of them, and define the formals as constrained first subtypes of 444 -- their bases. The bounds are expressions that are non-static in the 445 -- generic. 446 447 procedure Analyze_Formal_Decimal_Fixed_Point_Type 448 (T : Entity_Id; Def : Node_Id); 449 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); 450 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); 451 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); 452 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); 453 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 454 (T : Entity_Id; Def : Node_Id); 455 456 procedure Analyze_Formal_Private_Type 457 (N : Node_Id; 458 T : Entity_Id; 459 Def : Node_Id); 460 -- Creates a new private type, which does not require completion 461 462 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); 463 -- Ada 2012: Creates a new incomplete type whose actual does not freeze 464 465 procedure Analyze_Generic_Formal_Part (N : Node_Id); 466 -- Analyze generic formal part 467 468 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); 469 -- Create a new access type with the given designated type 470 471 function Analyze_Associations 472 (I_Node : Node_Id; 473 Formals : List_Id; 474 F_Copy : List_Id) return List_Id; 475 -- At instantiation time, build the list of associations between formals 476 -- and actuals. Each association becomes a renaming declaration for the 477 -- formal entity. F_Copy is the analyzed list of formals in the generic 478 -- copy. It is used to apply legality checks to the actuals. I_Node is the 479 -- instantiation node itself. 480 481 procedure Analyze_Subprogram_Instantiation 482 (N : Node_Id; 483 K : Entity_Kind); 484 485 procedure Build_Instance_Compilation_Unit_Nodes 486 (N : Node_Id; 487 Act_Body : Node_Id; 488 Act_Decl : Node_Id); 489 -- This procedure is used in the case where the generic instance of a 490 -- subprogram body or package body is a library unit. In this case, the 491 -- original library unit node for the generic instantiation must be 492 -- replaced by the resulting generic body, and a link made to a new 493 -- compilation unit node for the generic declaration. The argument N is 494 -- the original generic instantiation. Act_Body and Act_Decl are the body 495 -- and declaration of the instance (either package body and declaration 496 -- nodes or subprogram body and declaration nodes depending on the case). 497 -- On return, the node N has been rewritten with the actual body. 498 499 procedure Check_Access_Definition (N : Node_Id); 500 -- Subsidiary routine to null exclusion processing. Perform an assertion 501 -- check on Ada version and the presence of an access definition in N. 502 503 procedure Check_Formal_Packages (P_Id : Entity_Id); 504 -- Apply the following to all formal packages in generic associations 505 506 procedure Check_Formal_Package_Instance 507 (Formal_Pack : Entity_Id; 508 Actual_Pack : Entity_Id); 509 -- Verify that the actuals of the actual instance match the actuals of 510 -- the template for a formal package that is not declared with a box. 511 512 procedure Check_Forward_Instantiation (Decl : Node_Id); 513 -- If the generic is a local entity and the corresponding body has not 514 -- been seen yet, flag enclosing packages to indicate that it will be 515 -- elaborated after the generic body. Subprograms declared in the same 516 -- package cannot be inlined by the front-end because front-end inlining 517 -- requires a strict linear order of elaboration. 518 519 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; 520 -- Check if some association between formals and actuals requires to make 521 -- visible primitives of a tagged type, and make those primitives visible. 522 -- Return the list of primitives whose visibility is modified (to restore 523 -- their visibility later through Restore_Hidden_Primitives). If no 524 -- candidate is found then return No_Elist. 525 526 procedure Check_Hidden_Child_Unit 527 (N : Node_Id; 528 Gen_Unit : Entity_Id; 529 Act_Decl_Id : Entity_Id); 530 -- If the generic unit is an implicit child instance within a parent 531 -- instance, we need to make an explicit test that it is not hidden by 532 -- a child instance of the same name and parent. 533 534 procedure Check_Generic_Actuals 535 (Instance : Entity_Id; 536 Is_Formal_Box : Boolean); 537 -- Similar to previous one. Check the actuals in the instantiation, 538 -- whose views can change between the point of instantiation and the point 539 -- of instantiation of the body. In addition, mark the generic renamings 540 -- as generic actuals, so that they are not compatible with other actuals. 541 -- Recurse on an actual that is a formal package whose declaration has 542 -- a box. 543 544 function Contains_Instance_Of 545 (Inner : Entity_Id; 546 Outer : Entity_Id; 547 N : Node_Id) return Boolean; 548 -- Inner is instantiated within the generic Outer. Check whether Inner 549 -- directly or indirectly contains an instance of Outer or of one of its 550 -- parents, in the case of a subunit. Each generic unit holds a list of 551 -- the entities instantiated within (at any depth). This procedure 552 -- determines whether the set of such lists contains a cycle, i.e. an 553 -- illegal circular instantiation. 554 555 function Denotes_Formal_Package 556 (Pack : Entity_Id; 557 On_Exit : Boolean := False; 558 Instance : Entity_Id := Empty) return Boolean; 559 -- Returns True if E is a formal package of an enclosing generic, or 560 -- the actual for such a formal in an enclosing instantiation. If such 561 -- a package is used as a formal in an nested generic, or as an actual 562 -- in a nested instantiation, the visibility of ITS formals should not 563 -- be modified. When called from within Restore_Private_Views, the flag 564 -- On_Exit is true, to indicate that the search for a possible enclosing 565 -- instance should ignore the current one. In that case Instance denotes 566 -- the declaration for which this is an actual. This declaration may be 567 -- an instantiation in the source, or the internal instantiation that 568 -- corresponds to the actual for a formal package. 569 570 function Earlier (N1, N2 : Node_Id) return Boolean; 571 -- Yields True if N1 and N2 appear in the same compilation unit, 572 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right 573 -- traversal of the tree for the unit. Used to determine the placement 574 -- of freeze nodes for instance bodies that may depend on other instances. 575 576 function Find_Actual_Type 577 (Typ : Entity_Id; 578 Gen_Type : Entity_Id) return Entity_Id; 579 -- When validating the actual types of a child instance, check whether 580 -- the formal is a formal type of the parent unit, and retrieve the current 581 -- actual for it. Typ is the entity in the analyzed formal type declaration 582 -- (component or index type of an array type, or designated type of an 583 -- access formal) and Gen_Type is the enclosing analyzed formal array 584 -- or access type. The desired actual may be a formal of a parent, or may 585 -- be declared in a formal package of a parent. In both cases it is a 586 -- generic actual type because it appears within a visible instance. 587 -- Finally, it may be declared in a parent unit without being a formal 588 -- of that unit, in which case it must be retrieved by visibility. 589 -- Ambiguities may still arise if two homonyms are declared in two formal 590 -- packages, and the prefix of the formal type may be needed to resolve 591 -- the ambiguity in the instance ??? 592 593 procedure Freeze_Subprogram_Body 594 (Inst_Node : Node_Id; 595 Gen_Body : Node_Id; 596 Pack_Id : Entity_Id); 597 -- The generic body may appear textually after the instance, including 598 -- in the proper body of a stub, or within a different package instance. 599 -- Given that the instance can only be elaborated after the generic, we 600 -- place freeze_nodes for the instance and/or for packages that may enclose 601 -- the instance and the generic, so that the back-end can establish the 602 -- proper order of elaboration. 603 604 function Get_Associated_Node (N : Node_Id) return Node_Id; 605 -- In order to propagate semantic information back from the analyzed copy 606 -- to the original generic, we maintain links between selected nodes in the 607 -- generic and their corresponding copies. At the end of generic analysis, 608 -- the routine Save_Global_References traverses the generic tree, examines 609 -- the semantic information, and preserves the links to those nodes that 610 -- contain global information. At instantiation, the information from the 611 -- associated node is placed on the new copy, so that name resolution is 612 -- not repeated. 613 -- 614 -- Three kinds of source nodes have associated nodes: 615 -- 616 -- a) those that can reference (denote) entities, that is identifiers, 617 -- character literals, expanded_names, operator symbols, operators, 618 -- and attribute reference nodes. These nodes have an Entity field 619 -- and are the set of nodes that are in N_Has_Entity. 620 -- 621 -- b) aggregates (N_Aggregate and N_Extension_Aggregate) 622 -- 623 -- c) selected components (N_Selected_Component) 624 -- 625 -- For the first class, the associated node preserves the entity if it is 626 -- global. If the generic contains nested instantiations, the associated 627 -- node itself has been recopied, and a chain of them must be followed. 628 -- 629 -- For aggregates, the associated node allows retrieval of the type, which 630 -- may otherwise not appear in the generic. The view of this type may be 631 -- different between generic and instantiation, and the full view can be 632 -- installed before the instantiation is analyzed. For aggregates of type 633 -- extensions, the same view exchange may have to be performed for some of 634 -- the ancestor types, if their view is private at the point of 635 -- instantiation. 636 -- 637 -- Nodes that are selected components in the parse tree may be rewritten 638 -- as expanded names after resolution, and must be treated as potential 639 -- entity holders, which is why they also have an Associated_Node. 640 -- 641 -- Nodes that do not come from source, such as freeze nodes, do not appear 642 -- in the generic tree, and need not have an associated node. 643 -- 644 -- The associated node is stored in the Associated_Node field. Note that 645 -- this field overlaps Entity, which is fine, because the whole point is 646 -- that we don't need or want the normal Entity field in this situation. 647 648 function Has_Been_Exchanged (E : Entity_Id) return Boolean; 649 -- Traverse the Exchanged_Views list to see if a type was private 650 -- and has already been flipped during this phase of instantiation. 651 652 procedure Hide_Current_Scope; 653 -- When instantiating a generic child unit, the parent context must be 654 -- present, but the instance and all entities that may be generated 655 -- must be inserted in the current scope. We leave the current scope 656 -- on the stack, but make its entities invisible to avoid visibility 657 -- problems. This is reversed at the end of the instantiation. This is 658 -- not done for the instantiation of the bodies, which only require the 659 -- instances of the generic parents to be in scope. 660 661 function In_Same_Declarative_Part 662 (F_Node : Node_Id; 663 Inst : Node_Id) return Boolean; 664 -- True if the instantiation Inst and the given freeze_node F_Node appear 665 -- within the same declarative part, ignoring subunits, but with no inter- 666 -- vening subprograms or concurrent units. Used to find the proper plave 667 -- for the freeze node of an instance, when the generic is declared in a 668 -- previous instance. If predicate is true, the freeze node of the instance 669 -- can be placed after the freeze node of the previous instance, Otherwise 670 -- it has to be placed at the end of the current declarative part. 671 672 function In_Main_Context (E : Entity_Id) return Boolean; 673 -- Check whether an instantiation is in the context of the main unit. 674 -- Used to determine whether its body should be elaborated to allow 675 -- front-end inlining. 676 677 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); 678 -- Add the context clause of the unit containing a generic unit to a 679 -- compilation unit that is, or contains, an instantiation. 680 681 procedure Init_Env; 682 -- Establish environment for subsequent instantiation. Separated from 683 -- Save_Env because data-structures for visibility handling must be 684 -- initialized before call to Check_Generic_Child_Unit. 685 686 procedure Inline_Instance_Body 687 (N : Node_Id; 688 Gen_Unit : Entity_Id; 689 Act_Decl : Node_Id); 690 -- If front-end inlining is requested, instantiate the package body, 691 -- and preserve the visibility of its compilation unit, to insure 692 -- that successive instantiations succeed. 693 694 procedure Insert_Freeze_Node_For_Instance 695 (N : Node_Id; 696 F_Node : Node_Id); 697 -- N denotes a package or a subprogram instantiation and F_Node is the 698 -- associated freeze node. Insert the freeze node before the first source 699 -- body which follows immediately after N. If no such body is found, the 700 -- freeze node is inserted at the end of the declarative region which 701 -- contains N. 702 703 procedure Install_Body 704 (Act_Body : Node_Id; 705 N : Node_Id; 706 Gen_Body : Node_Id; 707 Gen_Decl : Node_Id); 708 -- If the instantiation happens textually before the body of the generic, 709 -- the instantiation of the body must be analyzed after the generic body, 710 -- and not at the point of instantiation. Such early instantiations can 711 -- happen if the generic and the instance appear in a package declaration 712 -- because the generic body can only appear in the corresponding package 713 -- body. Early instantiations can also appear if generic, instance and 714 -- body are all in the declarative part of a subprogram or entry. Entities 715 -- of packages that are early instantiations are delayed, and their freeze 716 -- node appears after the generic body. 717 718 procedure Install_Formal_Packages (Par : Entity_Id); 719 -- Install the visible part of any formal of the parent that is a formal 720 -- package. Note that for the case of a formal package with a box, this 721 -- includes the formal part of the formal package (12.7(10/2)). 722 723 procedure Install_Hidden_Primitives 724 (Prims_List : in out Elist_Id; 725 Gen_T : Entity_Id; 726 Act_T : Entity_Id); 727 -- Remove suffix 'P' from hidden primitives of Act_T to match the 728 -- visibility of primitives of Gen_T. The list of primitives to which 729 -- the suffix is removed is added to Prims_List to restore them later. 730 731 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 732 -- When compiling an instance of a child unit the parent (which is 733 -- itself an instance) is an enclosing scope that must be made 734 -- immediately visible. This procedure is also used to install the non- 735 -- generic parent of a generic child unit when compiling its body, so 736 -- that full views of types in the parent are made visible. 737 738 -- The functions Instantiate_XXX perform various legality checks and build 739 -- the declarations for instantiated generic parameters. In all of these 740 -- Formal is the entity in the generic unit, Actual is the entity of 741 -- expression in the generic associations, and Analyzed_Formal is the 742 -- formal in the generic copy, which contains the semantic information to 743 -- be used to validate the actual. 744 745 function Instantiate_Object 746 (Formal : Node_Id; 747 Actual : Node_Id; 748 Analyzed_Formal : Node_Id) return List_Id; 749 750 function Instantiate_Type 751 (Formal : Node_Id; 752 Actual : Node_Id; 753 Analyzed_Formal : Node_Id; 754 Actual_Decls : List_Id) return List_Id; 755 756 function Instantiate_Formal_Subprogram 757 (Formal : Node_Id; 758 Actual : Node_Id; 759 Analyzed_Formal : Node_Id) return Node_Id; 760 761 function Instantiate_Formal_Package 762 (Formal : Node_Id; 763 Actual : Node_Id; 764 Analyzed_Formal : Node_Id) return List_Id; 765 -- If the formal package is declared with a box, special visibility rules 766 -- apply to its formals: they are in the visible part of the package. This 767 -- is true in the declarative region of the formal package, that is to say 768 -- in the enclosing generic or instantiation. For an instantiation, the 769 -- parameters of the formal package are made visible in an explicit step. 770 -- Furthermore, if the actual has a visible USE clause, these formals must 771 -- be made potentially use-visible as well. On exit from the enclosing 772 -- instantiation, the reverse must be done. 773 774 -- For a formal package declared without a box, there are conformance rules 775 -- that apply to the actuals in the generic declaration and the actuals of 776 -- the actual package in the enclosing instantiation. The simplest way to 777 -- apply these rules is to repeat the instantiation of the formal package 778 -- in the context of the enclosing instance, and compare the generic 779 -- associations of this instantiation with those of the actual package. 780 -- This internal instantiation only needs to contain the renamings of the 781 -- formals: the visible and private declarations themselves need not be 782 -- created. 783 784 -- In Ada 2005, the formal package may be only partially parameterized. 785 -- In that case the visibility step must make visible those actuals whose 786 -- corresponding formals were given with a box. A final complication 787 -- involves inherited operations from formal derived types, which must 788 -- be visible if the type is. 789 790 function Is_In_Main_Unit (N : Node_Id) return Boolean; 791 -- Test if given node is in the main unit 792 793 procedure Load_Parent_Of_Generic 794 (N : Node_Id; 795 Spec : Node_Id; 796 Body_Optional : Boolean := False); 797 -- If the generic appears in a separate non-generic library unit, load the 798 -- corresponding body to retrieve the body of the generic. N is the node 799 -- for the generic instantiation, Spec is the generic package declaration. 800 -- 801 -- Body_Optional is a flag that indicates that the body is being loaded to 802 -- ensure that temporaries are generated consistently when there are other 803 -- instances in the current declarative part that precede the one being 804 -- loaded. In that case a missing body is acceptable. 805 806 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 807 -- Within the generic part, entities in the formal package are 808 -- visible. To validate subsequent type declarations, indicate 809 -- the correspondence between the entities in the analyzed formal, 810 -- and the entities in the actual package. There are three packages 811 -- involved in the instantiation of a formal package: the parent 812 -- generic P1 which appears in the generic declaration, the fake 813 -- instantiation P2 which appears in the analyzed generic, and whose 814 -- visible entities may be used in subsequent formals, and the actual 815 -- P3 in the instance. To validate subsequent formals, me indicate 816 -- that the entities in P2 are mapped into those of P3. The mapping of 817 -- entities has to be done recursively for nested packages. 818 819 procedure Move_Freeze_Nodes 820 (Out_Of : Entity_Id; 821 After : Node_Id; 822 L : List_Id); 823 -- Freeze nodes can be generated in the analysis of a generic unit, but 824 -- will not be seen by the back-end. It is necessary to move those nodes 825 -- to the enclosing scope if they freeze an outer entity. We place them 826 -- at the end of the enclosing generic package, which is semantically 827 -- neutral. 828 829 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty); 830 -- Analyze actuals to perform name resolution. Full resolution is done 831 -- later, when the expected types are known, but names have to be captured 832 -- before installing parents of generics, that are not visible for the 833 -- actuals themselves. 834 -- 835 -- If Inst is present, it is the entity of the package instance. This 836 -- entity is marked as having a limited_view actual when some actual is 837 -- a limited view. This is used to place the instance body properly. 838 839 procedure Remove_Parent (In_Body : Boolean := False); 840 -- Reverse effect after instantiation of child is complete 841 842 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 843 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 844 -- set to No_Elist. 845 846 procedure Set_Instance_Env 847 (Gen_Unit : Entity_Id; 848 Act_Unit : Entity_Id); 849 -- Save current instance on saved environment, to be used to determine 850 -- the global status of entities in nested instances. Part of Save_Env. 851 -- called after verifying that the generic unit is legal for the instance, 852 -- The procedure also examines whether the generic unit is a predefined 853 -- unit, in order to set configuration switches accordingly. As a result 854 -- the procedure must be called after analyzing and freezing the actuals. 855 856 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 857 -- Associate analyzed generic parameter with corresponding instance. Used 858 -- for semantic checks at instantiation time. 859 860 function True_Parent (N : Node_Id) return Node_Id; 861 -- For a subunit, return parent of corresponding stub, else return 862 -- parent of node. 863 864 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 865 -- Verify that an attribute that appears as the default for a formal 866 -- subprogram is a function or procedure with the correct profile. 867 868 ------------------------------------------- 869 -- Data Structures for Generic Renamings -- 870 ------------------------------------------- 871 872 -- The map Generic_Renamings associates generic entities with their 873 -- corresponding actuals. Currently used to validate type instances. It 874 -- will eventually be used for all generic parameters to eliminate the 875 -- need for overload resolution in the instance. 876 877 type Assoc_Ptr is new Int; 878 879 Assoc_Null : constant Assoc_Ptr := -1; 880 881 type Assoc is record 882 Gen_Id : Entity_Id; 883 Act_Id : Entity_Id; 884 Next_In_HTable : Assoc_Ptr; 885 end record; 886 887 package Generic_Renamings is new Table.Table 888 (Table_Component_Type => Assoc, 889 Table_Index_Type => Assoc_Ptr, 890 Table_Low_Bound => 0, 891 Table_Initial => 10, 892 Table_Increment => 100, 893 Table_Name => "Generic_Renamings"); 894 895 -- Variable to hold enclosing instantiation. When the environment is 896 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 897 898 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 899 900 -- Hash table for associations 901 902 HTable_Size : constant := 37; 903 type HTable_Range is range 0 .. HTable_Size - 1; 904 905 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 906 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 907 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 908 function Hash (F : Entity_Id) return HTable_Range; 909 910 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 911 Header_Num => HTable_Range, 912 Element => Assoc, 913 Elmt_Ptr => Assoc_Ptr, 914 Null_Ptr => Assoc_Null, 915 Set_Next => Set_Next_Assoc, 916 Next => Next_Assoc, 917 Key => Entity_Id, 918 Get_Key => Get_Gen_Id, 919 Hash => Hash, 920 Equal => "="); 921 922 Exchanged_Views : Elist_Id; 923 -- This list holds the private views that have been exchanged during 924 -- instantiation to restore the visibility of the generic declaration. 925 -- (see comments above). After instantiation, the current visibility is 926 -- reestablished by means of a traversal of this list. 927 928 Hidden_Entities : Elist_Id; 929 -- This list holds the entities of the current scope that are removed 930 -- from immediate visibility when instantiating a child unit. Their 931 -- visibility is restored in Remove_Parent. 932 933 -- Because instantiations can be recursive, the following must be saved 934 -- on entry and restored on exit from an instantiation (spec or body). 935 -- This is done by the two procedures Save_Env and Restore_Env. For 936 -- package and subprogram instantiations (but not for the body instances) 937 -- the action of Save_Env is done in two steps: Init_Env is called before 938 -- Check_Generic_Child_Unit, because setting the parent instances requires 939 -- that the visibility data structures be properly initialized. Once the 940 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 941 942 Parent_Unit_Visible : Boolean := False; 943 -- Parent_Unit_Visible is used when the generic is a child unit, and 944 -- indicates whether the ultimate parent of the generic is visible in the 945 -- instantiation environment. It is used to reset the visibility of the 946 -- parent at the end of the instantiation (see Remove_Parent). 947 948 Instance_Parent_Unit : Entity_Id := Empty; 949 -- This records the ultimate parent unit of an instance of a generic 950 -- child unit and is used in conjunction with Parent_Unit_Visible to 951 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 952 953 type Instance_Env is record 954 Instantiated_Parent : Assoc; 955 Exchanged_Views : Elist_Id; 956 Hidden_Entities : Elist_Id; 957 Current_Sem_Unit : Unit_Number_Type; 958 Parent_Unit_Visible : Boolean := False; 959 Instance_Parent_Unit : Entity_Id := Empty; 960 Switches : Config_Switches_Type; 961 end record; 962 963 package Instance_Envs is new Table.Table ( 964 Table_Component_Type => Instance_Env, 965 Table_Index_Type => Int, 966 Table_Low_Bound => 0, 967 Table_Initial => 32, 968 Table_Increment => 100, 969 Table_Name => "Instance_Envs"); 970 971 procedure Restore_Private_Views 972 (Pack_Id : Entity_Id; 973 Is_Package : Boolean := True); 974 -- Restore the private views of external types, and unmark the generic 975 -- renamings of actuals, so that they become compatible subtypes again. 976 -- For subprograms, Pack_Id is the package constructed to hold the 977 -- renamings. 978 979 procedure Switch_View (T : Entity_Id); 980 -- Switch the partial and full views of a type and its private 981 -- dependents (i.e. its subtypes and derived types). 982 983 ------------------------------------ 984 -- Structures for Error Reporting -- 985 ------------------------------------ 986 987 Instantiation_Node : Node_Id; 988 -- Used by subprograms that validate instantiation of formal parameters 989 -- where there might be no actual on which to place the error message. 990 -- Also used to locate the instantiation node for generic subunits. 991 992 Instantiation_Error : exception; 993 -- When there is a semantic error in the generic parameter matching, 994 -- there is no point in continuing the instantiation, because the 995 -- number of cascaded errors is unpredictable. This exception aborts 996 -- the instantiation process altogether. 997 998 S_Adjustment : Sloc_Adjustment; 999 -- Offset created for each node in an instantiation, in order to keep 1000 -- track of the source position of the instantiation in each of its nodes. 1001 -- A subsequent semantic error or warning on a construct of the instance 1002 -- points to both places: the original generic node, and the point of 1003 -- instantiation. See Sinput and Sinput.L for additional details. 1004 1005 ------------------------------------------------------------ 1006 -- Data structure for keeping track when inside a Generic -- 1007 ------------------------------------------------------------ 1008 1009 -- The following table is used to save values of the Inside_A_Generic 1010 -- flag (see spec of Sem) when they are saved by Start_Generic. 1011 1012 package Generic_Flags is new Table.Table ( 1013 Table_Component_Type => Boolean, 1014 Table_Index_Type => Int, 1015 Table_Low_Bound => 0, 1016 Table_Initial => 32, 1017 Table_Increment => 200, 1018 Table_Name => "Generic_Flags"); 1019 1020 --------------------------- 1021 -- Abandon_Instantiation -- 1022 --------------------------- 1023 1024 procedure Abandon_Instantiation (N : Node_Id) is 1025 begin 1026 Error_Msg_N ("\instantiation abandoned!", N); 1027 raise Instantiation_Error; 1028 end Abandon_Instantiation; 1029 1030 -------------------------- 1031 -- Analyze_Associations -- 1032 -------------------------- 1033 1034 function Analyze_Associations 1035 (I_Node : Node_Id; 1036 Formals : List_Id; 1037 F_Copy : List_Id) return List_Id 1038 is 1039 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 1040 Assoc : constant List_Id := New_List; 1041 Default_Actuals : constant List_Id := New_List; 1042 Gen_Unit : constant Entity_Id := 1043 Defining_Entity (Parent (F_Copy)); 1044 1045 Actuals : List_Id; 1046 Actual : Node_Id; 1047 Analyzed_Formal : Node_Id; 1048 First_Named : Node_Id := Empty; 1049 Formal : Node_Id; 1050 Match : Node_Id; 1051 Named : Node_Id; 1052 Saved_Formal : Node_Id; 1053 1054 Default_Formals : constant List_Id := New_List; 1055 -- If an Others_Choice is present, some of the formals may be defaulted. 1056 -- To simplify the treatment of visibility in an instance, we introduce 1057 -- individual defaults for each such formal. These defaults are 1058 -- appended to the list of associations and replace the Others_Choice. 1059 1060 Found_Assoc : Node_Id; 1061 -- Association for the current formal being match. Empty if there are 1062 -- no remaining actuals, or if there is no named association with the 1063 -- name of the formal. 1064 1065 Is_Named_Assoc : Boolean; 1066 Num_Matched : Int := 0; 1067 Num_Actuals : Int := 0; 1068 1069 Others_Present : Boolean := False; 1070 Others_Choice : Node_Id := Empty; 1071 -- In Ada 2005, indicates partial parameterization of a formal 1072 -- package. As usual an other association must be last in the list. 1073 1074 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 1075 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance 1076 -- cannot have a named association for it. AI05-0025 extends this rule 1077 -- to formals of formal packages by AI05-0025, and it also applies to 1078 -- box-initialized formals. 1079 1080 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 1081 -- Determine whether the parameter types and the return type of Subp 1082 -- are fully defined at the point of instantiation. 1083 1084 function Matching_Actual 1085 (F : Entity_Id; 1086 A_F : Entity_Id) return Node_Id; 1087 -- Find actual that corresponds to a given a formal parameter. If the 1088 -- actuals are positional, return the next one, if any. If the actuals 1089 -- are named, scan the parameter associations to find the right one. 1090 -- A_F is the corresponding entity in the analyzed generic,which is 1091 -- placed on the selector name for ASIS use. 1092 -- 1093 -- In Ada 2005, a named association may be given with a box, in which 1094 -- case Matching_Actual sets Found_Assoc to the generic association, 1095 -- but return Empty for the actual itself. In this case the code below 1096 -- creates a corresponding declaration for the formal. 1097 1098 function Partial_Parameterization return Boolean; 1099 -- Ada 2005: if no match is found for a given formal, check if the 1100 -- association for it includes a box, or whether the associations 1101 -- include an Others clause. 1102 1103 procedure Process_Default (F : Entity_Id); 1104 -- Add a copy of the declaration of generic formal F to the list of 1105 -- associations, and add an explicit box association for F if there 1106 -- is none yet, and the default comes from an Others_Choice. 1107 1108 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 1109 -- Determine whether Subp renames one of the subprograms defined in the 1110 -- generated package Standard. 1111 1112 procedure Set_Analyzed_Formal; 1113 -- Find the node in the generic copy that corresponds to a given formal. 1114 -- The semantic information on this node is used to perform legality 1115 -- checks on the actuals. Because semantic analysis can introduce some 1116 -- anonymous entities or modify the declaration node itself, the 1117 -- correspondence between the two lists is not one-one. In addition to 1118 -- anonymous types, the presence a formal equality will introduce an 1119 -- implicit declaration for the corresponding inequality. 1120 1121 ---------------------------------------- 1122 -- Check_Overloaded_Formal_Subprogram -- 1123 ---------------------------------------- 1124 1125 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1126 Temp_Formal : Entity_Id; 1127 1128 begin 1129 Temp_Formal := First (Formals); 1130 while Present (Temp_Formal) loop 1131 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1132 and then Temp_Formal /= Formal 1133 and then 1134 Chars (Defining_Unit_Name (Specification (Formal))) = 1135 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1136 then 1137 if Present (Found_Assoc) then 1138 Error_Msg_N 1139 ("named association not allowed for overloaded formal", 1140 Found_Assoc); 1141 1142 else 1143 Error_Msg_N 1144 ("named association not allowed for overloaded formal", 1145 Others_Choice); 1146 end if; 1147 1148 Abandon_Instantiation (Instantiation_Node); 1149 end if; 1150 1151 Next (Temp_Formal); 1152 end loop; 1153 end Check_Overloaded_Formal_Subprogram; 1154 1155 ------------------------------- 1156 -- Has_Fully_Defined_Profile -- 1157 ------------------------------- 1158 1159 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1160 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1161 -- Determine whethet type Typ is fully defined 1162 1163 --------------------------- 1164 -- Is_Fully_Defined_Type -- 1165 --------------------------- 1166 1167 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1168 begin 1169 -- A private type without a full view is not fully defined 1170 1171 if Is_Private_Type (Typ) 1172 and then No (Full_View (Typ)) 1173 then 1174 return False; 1175 1176 -- An incomplete type is never fully defined 1177 1178 elsif Is_Incomplete_Type (Typ) then 1179 return False; 1180 1181 -- All other types are fully defined 1182 1183 else 1184 return True; 1185 end if; 1186 end Is_Fully_Defined_Type; 1187 1188 -- Local declarations 1189 1190 Param : Entity_Id; 1191 1192 -- Start of processing for Has_Fully_Defined_Profile 1193 1194 begin 1195 -- Check the parameters 1196 1197 Param := First_Formal (Subp); 1198 while Present (Param) loop 1199 if not Is_Fully_Defined_Type (Etype (Param)) then 1200 return False; 1201 end if; 1202 1203 Next_Formal (Param); 1204 end loop; 1205 1206 -- Check the return type 1207 1208 return Is_Fully_Defined_Type (Etype (Subp)); 1209 end Has_Fully_Defined_Profile; 1210 1211 --------------------- 1212 -- Matching_Actual -- 1213 --------------------- 1214 1215 function Matching_Actual 1216 (F : Entity_Id; 1217 A_F : Entity_Id) return Node_Id 1218 is 1219 Prev : Node_Id; 1220 Act : Node_Id; 1221 1222 begin 1223 Is_Named_Assoc := False; 1224 1225 -- End of list of purely positional parameters 1226 1227 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1228 Found_Assoc := Empty; 1229 Act := Empty; 1230 1231 -- Case of positional parameter corresponding to current formal 1232 1233 elsif No (Selector_Name (Actual)) then 1234 Found_Assoc := Actual; 1235 Act := Explicit_Generic_Actual_Parameter (Actual); 1236 Num_Matched := Num_Matched + 1; 1237 Next (Actual); 1238 1239 -- Otherwise scan list of named actuals to find the one with the 1240 -- desired name. All remaining actuals have explicit names. 1241 1242 else 1243 Is_Named_Assoc := True; 1244 Found_Assoc := Empty; 1245 Act := Empty; 1246 Prev := Empty; 1247 1248 while Present (Actual) loop 1249 if Chars (Selector_Name (Actual)) = Chars (F) then 1250 Set_Entity (Selector_Name (Actual), A_F); 1251 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1252 Generate_Reference (A_F, Selector_Name (Actual)); 1253 Found_Assoc := Actual; 1254 Act := Explicit_Generic_Actual_Parameter (Actual); 1255 Num_Matched := Num_Matched + 1; 1256 exit; 1257 end if; 1258 1259 Prev := Actual; 1260 Next (Actual); 1261 end loop; 1262 1263 -- Reset for subsequent searches. In most cases the named 1264 -- associations are in order. If they are not, we reorder them 1265 -- to avoid scanning twice the same actual. This is not just a 1266 -- question of efficiency: there may be multiple defaults with 1267 -- boxes that have the same name. In a nested instantiation we 1268 -- insert actuals for those defaults, and cannot rely on their 1269 -- names to disambiguate them. 1270 1271 if Actual = First_Named then 1272 Next (First_Named); 1273 1274 elsif Present (Actual) then 1275 Insert_Before (First_Named, Remove_Next (Prev)); 1276 end if; 1277 1278 Actual := First_Named; 1279 end if; 1280 1281 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1282 Set_Used_As_Generic_Actual (Entity (Act)); 1283 end if; 1284 1285 return Act; 1286 end Matching_Actual; 1287 1288 ------------------------------ 1289 -- Partial_Parameterization -- 1290 ------------------------------ 1291 1292 function Partial_Parameterization return Boolean is 1293 begin 1294 return Others_Present 1295 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1296 end Partial_Parameterization; 1297 1298 --------------------- 1299 -- Process_Default -- 1300 --------------------- 1301 1302 procedure Process_Default (F : Entity_Id) is 1303 Loc : constant Source_Ptr := Sloc (I_Node); 1304 F_Id : constant Entity_Id := Defining_Entity (F); 1305 Decl : Node_Id; 1306 Default : Node_Id; 1307 Id : Entity_Id; 1308 1309 begin 1310 -- Append copy of formal declaration to associations, and create new 1311 -- defining identifier for it. 1312 1313 Decl := New_Copy_Tree (F); 1314 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1315 1316 if Nkind (F) in N_Formal_Subprogram_Declaration then 1317 Set_Defining_Unit_Name (Specification (Decl), Id); 1318 1319 else 1320 Set_Defining_Identifier (Decl, Id); 1321 end if; 1322 1323 Append (Decl, Assoc); 1324 1325 if No (Found_Assoc) then 1326 Default := 1327 Make_Generic_Association (Loc, 1328 Selector_Name => 1329 New_Occurrence_Of (Id, Loc), 1330 Explicit_Generic_Actual_Parameter => Empty); 1331 Set_Box_Present (Default); 1332 Append (Default, Default_Formals); 1333 end if; 1334 end Process_Default; 1335 1336 --------------------------------- 1337 -- Renames_Standard_Subprogram -- 1338 --------------------------------- 1339 1340 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1341 Id : Entity_Id; 1342 1343 begin 1344 Id := Alias (Subp); 1345 while Present (Id) loop 1346 if Scope (Id) = Standard_Standard then 1347 return True; 1348 end if; 1349 1350 Id := Alias (Id); 1351 end loop; 1352 1353 return False; 1354 end Renames_Standard_Subprogram; 1355 1356 ------------------------- 1357 -- Set_Analyzed_Formal -- 1358 ------------------------- 1359 1360 procedure Set_Analyzed_Formal is 1361 Kind : Node_Kind; 1362 1363 begin 1364 while Present (Analyzed_Formal) loop 1365 Kind := Nkind (Analyzed_Formal); 1366 1367 case Nkind (Formal) is 1368 1369 when N_Formal_Subprogram_Declaration => 1370 exit when Kind in N_Formal_Subprogram_Declaration 1371 and then 1372 Chars 1373 (Defining_Unit_Name (Specification (Formal))) = 1374 Chars 1375 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1376 1377 when N_Formal_Package_Declaration => 1378 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1379 N_Generic_Package_Declaration, 1380 N_Package_Declaration); 1381 1382 when N_Use_Package_Clause | N_Use_Type_Clause => exit; 1383 1384 when others => 1385 1386 -- Skip freeze nodes, and nodes inserted to replace 1387 -- unrecognized pragmas. 1388 1389 exit when 1390 Kind not in N_Formal_Subprogram_Declaration 1391 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1392 N_Freeze_Entity, 1393 N_Null_Statement, 1394 N_Itype_Reference) 1395 and then Chars (Defining_Identifier (Formal)) = 1396 Chars (Defining_Identifier (Analyzed_Formal)); 1397 end case; 1398 1399 Next (Analyzed_Formal); 1400 end loop; 1401 end Set_Analyzed_Formal; 1402 1403 -- Start of processing for Analyze_Associations 1404 1405 begin 1406 Actuals := Generic_Associations (I_Node); 1407 1408 if Present (Actuals) then 1409 1410 -- Check for an Others choice, indicating a partial parameterization 1411 -- for a formal package. 1412 1413 Actual := First (Actuals); 1414 while Present (Actual) loop 1415 if Nkind (Actual) = N_Others_Choice then 1416 Others_Present := True; 1417 Others_Choice := Actual; 1418 1419 if Present (Next (Actual)) then 1420 Error_Msg_N ("others must be last association", Actual); 1421 end if; 1422 1423 -- This subprogram is used both for formal packages and for 1424 -- instantiations. For the latter, associations must all be 1425 -- explicit. 1426 1427 if Nkind (I_Node) /= N_Formal_Package_Declaration 1428 and then Comes_From_Source (I_Node) 1429 then 1430 Error_Msg_N 1431 ("others association not allowed in an instance", 1432 Actual); 1433 end if; 1434 1435 -- In any case, nothing to do after the others association 1436 1437 exit; 1438 1439 elsif Box_Present (Actual) 1440 and then Comes_From_Source (I_Node) 1441 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1442 then 1443 Error_Msg_N 1444 ("box association not allowed in an instance", Actual); 1445 end if; 1446 1447 Next (Actual); 1448 end loop; 1449 1450 -- If named associations are present, save first named association 1451 -- (it may of course be Empty) to facilitate subsequent name search. 1452 1453 First_Named := First (Actuals); 1454 while Present (First_Named) 1455 and then Nkind (First_Named) /= N_Others_Choice 1456 and then No (Selector_Name (First_Named)) 1457 loop 1458 Num_Actuals := Num_Actuals + 1; 1459 Next (First_Named); 1460 end loop; 1461 end if; 1462 1463 Named := First_Named; 1464 while Present (Named) loop 1465 if Nkind (Named) /= N_Others_Choice 1466 and then No (Selector_Name (Named)) 1467 then 1468 Error_Msg_N ("invalid positional actual after named one", Named); 1469 Abandon_Instantiation (Named); 1470 end if; 1471 1472 -- A named association may lack an actual parameter, if it was 1473 -- introduced for a default subprogram that turns out to be local 1474 -- to the outer instantiation. 1475 1476 if Nkind (Named) /= N_Others_Choice 1477 and then Present (Explicit_Generic_Actual_Parameter (Named)) 1478 then 1479 Num_Actuals := Num_Actuals + 1; 1480 end if; 1481 1482 Next (Named); 1483 end loop; 1484 1485 if Present (Formals) then 1486 Formal := First_Non_Pragma (Formals); 1487 Analyzed_Formal := First_Non_Pragma (F_Copy); 1488 1489 if Present (Actuals) then 1490 Actual := First (Actuals); 1491 1492 -- All formals should have default values 1493 1494 else 1495 Actual := Empty; 1496 end if; 1497 1498 while Present (Formal) loop 1499 Set_Analyzed_Formal; 1500 Saved_Formal := Next_Non_Pragma (Formal); 1501 1502 case Nkind (Formal) is 1503 when N_Formal_Object_Declaration => 1504 Match := 1505 Matching_Actual 1506 (Defining_Identifier (Formal), 1507 Defining_Identifier (Analyzed_Formal)); 1508 1509 if No (Match) and then Partial_Parameterization then 1510 Process_Default (Formal); 1511 1512 else 1513 Append_List 1514 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1515 Assoc); 1516 1517 -- For a defaulted in_parameter, create an entry in the 1518 -- the list of defaulted actuals, for GNATProve use. Do 1519 -- not included these defaults for an instance nested 1520 -- within a generic, because the defaults are also used 1521 -- in the analysis of the enclosing generic, and only 1522 -- defaulted subprograms are relevant there. 1523 1524 if No (Match) and then not Inside_A_Generic then 1525 Append_To (Default_Actuals, 1526 Make_Generic_Association (Sloc (I_Node), 1527 Selector_Name => 1528 New_Occurrence_Of 1529 (Defining_Identifier (Formal), Sloc (I_Node)), 1530 Explicit_Generic_Actual_Parameter => 1531 New_Copy_Tree (Default_Expression (Formal)))); 1532 end if; 1533 end if; 1534 1535 -- If the object is a call to an expression function, this 1536 -- is a freezing point for it. 1537 1538 if Is_Entity_Name (Match) 1539 and then Present (Entity (Match)) 1540 and then Nkind 1541 (Original_Node (Unit_Declaration_Node (Entity (Match)))) 1542 = N_Expression_Function 1543 then 1544 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1545 end if; 1546 1547 when N_Formal_Type_Declaration => 1548 Match := 1549 Matching_Actual 1550 (Defining_Identifier (Formal), 1551 Defining_Identifier (Analyzed_Formal)); 1552 1553 if No (Match) then 1554 if Partial_Parameterization then 1555 Process_Default (Formal); 1556 1557 else 1558 Error_Msg_Sloc := Sloc (Gen_Unit); 1559 Error_Msg_NE 1560 ("missing actual&", 1561 Instantiation_Node, Defining_Identifier (Formal)); 1562 Error_Msg_NE 1563 ("\in instantiation of & declared#", 1564 Instantiation_Node, Gen_Unit); 1565 Abandon_Instantiation (Instantiation_Node); 1566 end if; 1567 1568 else 1569 Analyze (Match); 1570 Append_List 1571 (Instantiate_Type 1572 (Formal, Match, Analyzed_Formal, Assoc), 1573 Assoc); 1574 1575 -- An instantiation is a freeze point for the actuals, 1576 -- unless this is a rewritten formal package, or the 1577 -- formal is an Ada 2012 formal incomplete type. 1578 1579 if Nkind (I_Node) = N_Formal_Package_Declaration 1580 or else 1581 (Ada_Version >= Ada_2012 1582 and then 1583 Ekind (Defining_Identifier (Analyzed_Formal)) = 1584 E_Incomplete_Type) 1585 then 1586 null; 1587 1588 else 1589 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1590 end if; 1591 end if; 1592 1593 -- A remote access-to-class-wide type is not a legal actual 1594 -- for a generic formal of an access type (E.2.2(17/2)). 1595 -- In GNAT an exception to this rule is introduced when 1596 -- the formal is marked as remote using implementation 1597 -- defined aspect/pragma Remote_Access_Type. In that case 1598 -- the actual must be remote as well. 1599 1600 -- If the current instantiation is the construction of a 1601 -- local copy for a formal package the actuals may be 1602 -- defaulted, and there is no matching actual to check. 1603 1604 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1605 and then 1606 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1607 N_Access_To_Object_Definition 1608 and then Present (Match) 1609 then 1610 declare 1611 Formal_Ent : constant Entity_Id := 1612 Defining_Identifier (Analyzed_Formal); 1613 begin 1614 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1615 = Is_Remote_Types (Formal_Ent) 1616 then 1617 -- Remoteness of formal and actual match 1618 1619 null; 1620 1621 elsif Is_Remote_Types (Formal_Ent) then 1622 1623 -- Remote formal, non-remote actual 1624 1625 Error_Msg_NE 1626 ("actual for& must be remote", Match, Formal_Ent); 1627 1628 else 1629 -- Non-remote formal, remote actual 1630 1631 Error_Msg_NE 1632 ("actual for& may not be remote", 1633 Match, Formal_Ent); 1634 end if; 1635 end; 1636 end if; 1637 1638 when N_Formal_Subprogram_Declaration => 1639 Match := 1640 Matching_Actual 1641 (Defining_Unit_Name (Specification (Formal)), 1642 Defining_Unit_Name (Specification (Analyzed_Formal))); 1643 1644 -- If the formal subprogram has the same name as another 1645 -- formal subprogram of the generic, then a named 1646 -- association is illegal (12.3(9)). Exclude named 1647 -- associations that are generated for a nested instance. 1648 1649 if Present (Match) 1650 and then Is_Named_Assoc 1651 and then Comes_From_Source (Found_Assoc) 1652 then 1653 Check_Overloaded_Formal_Subprogram (Formal); 1654 end if; 1655 1656 -- If there is no corresponding actual, this may be case 1657 -- of partial parameterization, or else the formal has a 1658 -- default or a box. 1659 1660 if No (Match) and then Partial_Parameterization then 1661 Process_Default (Formal); 1662 1663 if Nkind (I_Node) = N_Formal_Package_Declaration then 1664 Check_Overloaded_Formal_Subprogram (Formal); 1665 end if; 1666 1667 else 1668 Append_To (Assoc, 1669 Instantiate_Formal_Subprogram 1670 (Formal, Match, Analyzed_Formal)); 1671 1672 -- An instantiation is a freeze point for the actuals, 1673 -- unless this is a rewritten formal package. 1674 1675 if Nkind (I_Node) /= N_Formal_Package_Declaration 1676 and then Nkind (Match) = N_Identifier 1677 and then Is_Subprogram (Entity (Match)) 1678 1679 -- The actual subprogram may rename a routine defined 1680 -- in Standard. Avoid freezing such renamings because 1681 -- subprograms coming from Standard cannot be frozen. 1682 1683 and then 1684 not Renames_Standard_Subprogram (Entity (Match)) 1685 1686 -- If the actual subprogram comes from a different 1687 -- unit, it is already frozen, either by a body in 1688 -- that unit or by the end of the declarative part 1689 -- of the unit. This check avoids the freezing of 1690 -- subprograms defined in Standard which are used 1691 -- as generic actuals. 1692 1693 and then In_Same_Code_Unit (Entity (Match), I_Node) 1694 and then Has_Fully_Defined_Profile (Entity (Match)) 1695 then 1696 -- Mark the subprogram as having a delayed freeze 1697 -- since this may be an out-of-order action. 1698 1699 Set_Has_Delayed_Freeze (Entity (Match)); 1700 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1701 end if; 1702 end if; 1703 1704 -- If this is a nested generic, preserve default for later 1705 -- instantiations. We do this as well for GNATProve use, 1706 -- so that the list of generic associations is complete. 1707 1708 if No (Match) and then Box_Present (Formal) then 1709 declare 1710 Subp : constant Entity_Id := 1711 Defining_Unit_Name (Specification (Last (Assoc))); 1712 1713 begin 1714 Append_To (Default_Actuals, 1715 Make_Generic_Association (Sloc (I_Node), 1716 Selector_Name => 1717 New_Occurrence_Of (Subp, Sloc (I_Node)), 1718 Explicit_Generic_Actual_Parameter => 1719 New_Occurrence_Of (Subp, Sloc (I_Node)))); 1720 end; 1721 end if; 1722 1723 when N_Formal_Package_Declaration => 1724 Match := 1725 Matching_Actual 1726 (Defining_Identifier (Formal), 1727 Defining_Identifier (Original_Node (Analyzed_Formal))); 1728 1729 if No (Match) then 1730 if Partial_Parameterization then 1731 Process_Default (Formal); 1732 1733 else 1734 Error_Msg_Sloc := Sloc (Gen_Unit); 1735 Error_Msg_NE 1736 ("missing actual&", 1737 Instantiation_Node, Defining_Identifier (Formal)); 1738 Error_Msg_NE 1739 ("\in instantiation of & declared#", 1740 Instantiation_Node, Gen_Unit); 1741 1742 Abandon_Instantiation (Instantiation_Node); 1743 end if; 1744 1745 else 1746 Analyze (Match); 1747 Append_List 1748 (Instantiate_Formal_Package 1749 (Formal, Match, Analyzed_Formal), 1750 Assoc); 1751 end if; 1752 1753 -- For use type and use package appearing in the generic part, 1754 -- we have already copied them, so we can just move them where 1755 -- they belong (we mustn't recopy them since this would mess up 1756 -- the Sloc values). 1757 1758 when N_Use_Package_Clause | 1759 N_Use_Type_Clause => 1760 if Nkind (Original_Node (I_Node)) = 1761 N_Formal_Package_Declaration 1762 then 1763 Append (New_Copy_Tree (Formal), Assoc); 1764 else 1765 Remove (Formal); 1766 Append (Formal, Assoc); 1767 end if; 1768 1769 when others => 1770 raise Program_Error; 1771 1772 end case; 1773 1774 Formal := Saved_Formal; 1775 Next_Non_Pragma (Analyzed_Formal); 1776 end loop; 1777 1778 if Num_Actuals > Num_Matched then 1779 Error_Msg_Sloc := Sloc (Gen_Unit); 1780 1781 if Present (Selector_Name (Actual)) then 1782 Error_Msg_NE 1783 ("unmatched actual &", Actual, Selector_Name (Actual)); 1784 Error_Msg_NE 1785 ("\in instantiation of & declared#", Actual, Gen_Unit); 1786 else 1787 Error_Msg_NE 1788 ("unmatched actual in instantiation of & declared#", 1789 Actual, Gen_Unit); 1790 end if; 1791 end if; 1792 1793 elsif Present (Actuals) then 1794 Error_Msg_N 1795 ("too many actuals in generic instantiation", Instantiation_Node); 1796 end if; 1797 1798 -- An instantiation freezes all generic actuals. The only exceptions 1799 -- to this are incomplete types and subprograms which are not fully 1800 -- defined at the point of instantiation. 1801 1802 declare 1803 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 1804 begin 1805 while Present (Elmt) loop 1806 Freeze_Before (I_Node, Node (Elmt)); 1807 Next_Elmt (Elmt); 1808 end loop; 1809 end; 1810 1811 -- If there are default subprograms, normalize the tree by adding 1812 -- explicit associations for them. This is required if the instance 1813 -- appears within a generic. 1814 1815 if not Is_Empty_List (Default_Actuals) then 1816 declare 1817 Default : Node_Id; 1818 1819 begin 1820 Default := First (Default_Actuals); 1821 while Present (Default) loop 1822 Mark_Rewrite_Insertion (Default); 1823 Next (Default); 1824 end loop; 1825 1826 if No (Actuals) then 1827 Set_Generic_Associations (I_Node, Default_Actuals); 1828 else 1829 Append_List_To (Actuals, Default_Actuals); 1830 end if; 1831 end; 1832 end if; 1833 1834 -- If this is a formal package, normalize the parameter list by adding 1835 -- explicit box associations for the formals that are covered by an 1836 -- Others_Choice. 1837 1838 if not Is_Empty_List (Default_Formals) then 1839 Append_List (Default_Formals, Formals); 1840 end if; 1841 1842 return Assoc; 1843 end Analyze_Associations; 1844 1845 ------------------------------- 1846 -- Analyze_Formal_Array_Type -- 1847 ------------------------------- 1848 1849 procedure Analyze_Formal_Array_Type 1850 (T : in out Entity_Id; 1851 Def : Node_Id) 1852 is 1853 DSS : Node_Id; 1854 1855 begin 1856 -- Treated like a non-generic array declaration, with additional 1857 -- semantic checks. 1858 1859 Enter_Name (T); 1860 1861 if Nkind (Def) = N_Constrained_Array_Definition then 1862 DSS := First (Discrete_Subtype_Definitions (Def)); 1863 while Present (DSS) loop 1864 if Nkind_In (DSS, N_Subtype_Indication, 1865 N_Range, 1866 N_Attribute_Reference) 1867 then 1868 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 1869 end if; 1870 1871 Next (DSS); 1872 end loop; 1873 end if; 1874 1875 Array_Type_Declaration (T, Def); 1876 Set_Is_Generic_Type (Base_Type (T)); 1877 1878 if Ekind (Component_Type (T)) = E_Incomplete_Type 1879 and then No (Full_View (Component_Type (T))) 1880 then 1881 Error_Msg_N ("premature usage of incomplete type", Def); 1882 1883 -- Check that range constraint is not allowed on the component type 1884 -- of a generic formal array type (AARM 12.5.3(3)) 1885 1886 elsif Is_Internal (Component_Type (T)) 1887 and then Present (Subtype_Indication (Component_Definition (Def))) 1888 and then Nkind (Original_Node 1889 (Subtype_Indication (Component_Definition (Def)))) = 1890 N_Subtype_Indication 1891 then 1892 Error_Msg_N 1893 ("in a formal, a subtype indication can only be " 1894 & "a subtype mark (RM 12.5.3(3))", 1895 Subtype_Indication (Component_Definition (Def))); 1896 end if; 1897 1898 end Analyze_Formal_Array_Type; 1899 1900 --------------------------------------------- 1901 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 1902 --------------------------------------------- 1903 1904 -- As for other generic types, we create a valid type representation with 1905 -- legal but arbitrary attributes, whose values are never considered 1906 -- static. For all scalar types we introduce an anonymous base type, with 1907 -- the same attributes. We choose the corresponding integer type to be 1908 -- Standard_Integer. 1909 -- Here and in other similar routines, the Sloc of the generated internal 1910 -- type must be the same as the sloc of the defining identifier of the 1911 -- formal type declaration, to provide proper source navigation. 1912 1913 procedure Analyze_Formal_Decimal_Fixed_Point_Type 1914 (T : Entity_Id; 1915 Def : Node_Id) 1916 is 1917 Loc : constant Source_Ptr := Sloc (Def); 1918 1919 Base : constant Entity_Id := 1920 New_Internal_Entity 1921 (E_Decimal_Fixed_Point_Type, 1922 Current_Scope, 1923 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1924 1925 Int_Base : constant Entity_Id := Standard_Integer; 1926 Delta_Val : constant Ureal := Ureal_1; 1927 Digs_Val : constant Uint := Uint_6; 1928 1929 function Make_Dummy_Bound return Node_Id; 1930 -- Return a properly typed universal real literal to use as a bound 1931 1932 ---------------------- 1933 -- Make_Dummy_Bound -- 1934 ---------------------- 1935 1936 function Make_Dummy_Bound return Node_Id is 1937 Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1); 1938 begin 1939 Set_Etype (Bound, Universal_Real); 1940 return Bound; 1941 end Make_Dummy_Bound; 1942 1943 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type 1944 1945 begin 1946 Enter_Name (T); 1947 1948 Set_Etype (Base, Base); 1949 Set_Size_Info (Base, Int_Base); 1950 Set_RM_Size (Base, RM_Size (Int_Base)); 1951 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 1952 Set_Digits_Value (Base, Digs_Val); 1953 Set_Delta_Value (Base, Delta_Val); 1954 Set_Small_Value (Base, Delta_Val); 1955 Set_Scalar_Range (Base, 1956 Make_Range (Loc, 1957 Low_Bound => Make_Dummy_Bound, 1958 High_Bound => Make_Dummy_Bound)); 1959 1960 Set_Is_Generic_Type (Base); 1961 Set_Parent (Base, Parent (Def)); 1962 1963 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 1964 Set_Etype (T, Base); 1965 Set_Size_Info (T, Int_Base); 1966 Set_RM_Size (T, RM_Size (Int_Base)); 1967 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 1968 Set_Digits_Value (T, Digs_Val); 1969 Set_Delta_Value (T, Delta_Val); 1970 Set_Small_Value (T, Delta_Val); 1971 Set_Scalar_Range (T, Scalar_Range (Base)); 1972 Set_Is_Constrained (T); 1973 1974 Check_Restriction (No_Fixed_Point, Def); 1975 end Analyze_Formal_Decimal_Fixed_Point_Type; 1976 1977 ------------------------------------------- 1978 -- Analyze_Formal_Derived_Interface_Type -- 1979 ------------------------------------------- 1980 1981 procedure Analyze_Formal_Derived_Interface_Type 1982 (N : Node_Id; 1983 T : Entity_Id; 1984 Def : Node_Id) 1985 is 1986 Loc : constant Source_Ptr := Sloc (Def); 1987 1988 begin 1989 -- Rewrite as a type declaration of a derived type. This ensures that 1990 -- the interface list and primitive operations are properly captured. 1991 1992 Rewrite (N, 1993 Make_Full_Type_Declaration (Loc, 1994 Defining_Identifier => T, 1995 Type_Definition => Def)); 1996 Analyze (N); 1997 Set_Is_Generic_Type (T); 1998 end Analyze_Formal_Derived_Interface_Type; 1999 2000 --------------------------------- 2001 -- Analyze_Formal_Derived_Type -- 2002 --------------------------------- 2003 2004 procedure Analyze_Formal_Derived_Type 2005 (N : Node_Id; 2006 T : Entity_Id; 2007 Def : Node_Id) 2008 is 2009 Loc : constant Source_Ptr := Sloc (Def); 2010 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 2011 New_N : Node_Id; 2012 2013 begin 2014 Set_Is_Generic_Type (T); 2015 2016 if Private_Present (Def) then 2017 New_N := 2018 Make_Private_Extension_Declaration (Loc, 2019 Defining_Identifier => T, 2020 Discriminant_Specifications => Discriminant_Specifications (N), 2021 Unknown_Discriminants_Present => Unk_Disc, 2022 Subtype_Indication => Subtype_Mark (Def), 2023 Interface_List => Interface_List (Def)); 2024 2025 Set_Abstract_Present (New_N, Abstract_Present (Def)); 2026 Set_Limited_Present (New_N, Limited_Present (Def)); 2027 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 2028 2029 else 2030 New_N := 2031 Make_Full_Type_Declaration (Loc, 2032 Defining_Identifier => T, 2033 Discriminant_Specifications => 2034 Discriminant_Specifications (Parent (T)), 2035 Type_Definition => 2036 Make_Derived_Type_Definition (Loc, 2037 Subtype_Indication => Subtype_Mark (Def))); 2038 2039 Set_Abstract_Present 2040 (Type_Definition (New_N), Abstract_Present (Def)); 2041 Set_Limited_Present 2042 (Type_Definition (New_N), Limited_Present (Def)); 2043 end if; 2044 2045 Rewrite (N, New_N); 2046 Analyze (N); 2047 2048 if Unk_Disc then 2049 if not Is_Composite_Type (T) then 2050 Error_Msg_N 2051 ("unknown discriminants not allowed for elementary types", N); 2052 else 2053 Set_Has_Unknown_Discriminants (T); 2054 Set_Is_Constrained (T, False); 2055 end if; 2056 end if; 2057 2058 -- If the parent type has a known size, so does the formal, which makes 2059 -- legal representation clauses that involve the formal. 2060 2061 Set_Size_Known_At_Compile_Time 2062 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 2063 end Analyze_Formal_Derived_Type; 2064 2065 ---------------------------------- 2066 -- Analyze_Formal_Discrete_Type -- 2067 ---------------------------------- 2068 2069 -- The operations defined for a discrete types are those of an enumeration 2070 -- type. The size is set to an arbitrary value, for use in analyzing the 2071 -- generic unit. 2072 2073 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 2074 Loc : constant Source_Ptr := Sloc (Def); 2075 Lo : Node_Id; 2076 Hi : Node_Id; 2077 2078 Base : constant Entity_Id := 2079 New_Internal_Entity 2080 (E_Floating_Point_Type, Current_Scope, 2081 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2082 2083 begin 2084 Enter_Name (T); 2085 Set_Ekind (T, E_Enumeration_Subtype); 2086 Set_Etype (T, Base); 2087 Init_Size (T, 8); 2088 Init_Alignment (T); 2089 Set_Is_Generic_Type (T); 2090 Set_Is_Constrained (T); 2091 2092 -- For semantic analysis, the bounds of the type must be set to some 2093 -- non-static value. The simplest is to create attribute nodes for those 2094 -- bounds, that refer to the type itself. These bounds are never 2095 -- analyzed but serve as place-holders. 2096 2097 Lo := 2098 Make_Attribute_Reference (Loc, 2099 Attribute_Name => Name_First, 2100 Prefix => New_Occurrence_Of (T, Loc)); 2101 Set_Etype (Lo, T); 2102 2103 Hi := 2104 Make_Attribute_Reference (Loc, 2105 Attribute_Name => Name_Last, 2106 Prefix => New_Occurrence_Of (T, Loc)); 2107 Set_Etype (Hi, T); 2108 2109 Set_Scalar_Range (T, 2110 Make_Range (Loc, 2111 Low_Bound => Lo, 2112 High_Bound => Hi)); 2113 2114 Set_Ekind (Base, E_Enumeration_Type); 2115 Set_Etype (Base, Base); 2116 Init_Size (Base, 8); 2117 Init_Alignment (Base); 2118 Set_Is_Generic_Type (Base); 2119 Set_Scalar_Range (Base, Scalar_Range (T)); 2120 Set_Parent (Base, Parent (Def)); 2121 end Analyze_Formal_Discrete_Type; 2122 2123 ---------------------------------- 2124 -- Analyze_Formal_Floating_Type -- 2125 --------------------------------- 2126 2127 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 2128 Base : constant Entity_Id := 2129 New_Internal_Entity 2130 (E_Floating_Point_Type, Current_Scope, 2131 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2132 2133 begin 2134 -- The various semantic attributes are taken from the predefined type 2135 -- Float, just so that all of them are initialized. Their values are 2136 -- never used because no constant folding or expansion takes place in 2137 -- the generic itself. 2138 2139 Enter_Name (T); 2140 Set_Ekind (T, E_Floating_Point_Subtype); 2141 Set_Etype (T, Base); 2142 Set_Size_Info (T, (Standard_Float)); 2143 Set_RM_Size (T, RM_Size (Standard_Float)); 2144 Set_Digits_Value (T, Digits_Value (Standard_Float)); 2145 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 2146 Set_Is_Constrained (T); 2147 2148 Set_Is_Generic_Type (Base); 2149 Set_Etype (Base, Base); 2150 Set_Size_Info (Base, (Standard_Float)); 2151 Set_RM_Size (Base, RM_Size (Standard_Float)); 2152 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 2153 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 2154 Set_Parent (Base, Parent (Def)); 2155 2156 Check_Restriction (No_Floating_Point, Def); 2157 end Analyze_Formal_Floating_Type; 2158 2159 ----------------------------------- 2160 -- Analyze_Formal_Interface_Type;-- 2161 ----------------------------------- 2162 2163 procedure Analyze_Formal_Interface_Type 2164 (N : Node_Id; 2165 T : Entity_Id; 2166 Def : Node_Id) 2167 is 2168 Loc : constant Source_Ptr := Sloc (N); 2169 New_N : Node_Id; 2170 2171 begin 2172 New_N := 2173 Make_Full_Type_Declaration (Loc, 2174 Defining_Identifier => T, 2175 Type_Definition => Def); 2176 2177 Rewrite (N, New_N); 2178 Analyze (N); 2179 Set_Is_Generic_Type (T); 2180 end Analyze_Formal_Interface_Type; 2181 2182 --------------------------------- 2183 -- Analyze_Formal_Modular_Type -- 2184 --------------------------------- 2185 2186 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2187 begin 2188 -- Apart from their entity kind, generic modular types are treated like 2189 -- signed integer types, and have the same attributes. 2190 2191 Analyze_Formal_Signed_Integer_Type (T, Def); 2192 Set_Ekind (T, E_Modular_Integer_Subtype); 2193 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2194 2195 end Analyze_Formal_Modular_Type; 2196 2197 --------------------------------------- 2198 -- Analyze_Formal_Object_Declaration -- 2199 --------------------------------------- 2200 2201 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2202 E : constant Node_Id := Default_Expression (N); 2203 Id : constant Node_Id := Defining_Identifier (N); 2204 K : Entity_Kind; 2205 T : Node_Id; 2206 2207 begin 2208 Enter_Name (Id); 2209 2210 -- Determine the mode of the formal object 2211 2212 if Out_Present (N) then 2213 K := E_Generic_In_Out_Parameter; 2214 2215 if not In_Present (N) then 2216 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2217 end if; 2218 2219 else 2220 K := E_Generic_In_Parameter; 2221 end if; 2222 2223 if Present (Subtype_Mark (N)) then 2224 Find_Type (Subtype_Mark (N)); 2225 T := Entity (Subtype_Mark (N)); 2226 2227 -- Verify that there is no redundant null exclusion 2228 2229 if Null_Exclusion_Present (N) then 2230 if not Is_Access_Type (T) then 2231 Error_Msg_N 2232 ("null exclusion can only apply to an access type", N); 2233 2234 elsif Can_Never_Be_Null (T) then 2235 Error_Msg_NE 2236 ("`NOT NULL` not allowed (& already excludes null)", N, T); 2237 end if; 2238 end if; 2239 2240 -- Ada 2005 (AI-423): Formal object with an access definition 2241 2242 else 2243 Check_Access_Definition (N); 2244 T := Access_Definition 2245 (Related_Nod => N, 2246 N => Access_Definition (N)); 2247 end if; 2248 2249 if Ekind (T) = E_Incomplete_Type then 2250 declare 2251 Error_Node : Node_Id; 2252 2253 begin 2254 if Present (Subtype_Mark (N)) then 2255 Error_Node := Subtype_Mark (N); 2256 else 2257 Check_Access_Definition (N); 2258 Error_Node := Access_Definition (N); 2259 end if; 2260 2261 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2262 end; 2263 end if; 2264 2265 if K = E_Generic_In_Parameter then 2266 2267 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2268 2269 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2270 Error_Msg_N 2271 ("generic formal of mode IN must not be of limited type", N); 2272 Explain_Limited_Type (T, N); 2273 end if; 2274 2275 if Is_Abstract_Type (T) then 2276 Error_Msg_N 2277 ("generic formal of mode IN must not be of abstract type", N); 2278 end if; 2279 2280 if Present (E) then 2281 Preanalyze_Spec_Expression (E, T); 2282 2283 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2284 Error_Msg_N 2285 ("initialization not allowed for limited types", E); 2286 Explain_Limited_Type (T, E); 2287 end if; 2288 end if; 2289 2290 Set_Ekind (Id, K); 2291 Set_Etype (Id, T); 2292 2293 -- Case of generic IN OUT parameter 2294 2295 else 2296 -- If the formal has an unconstrained type, construct its actual 2297 -- subtype, as is done for subprogram formals. In this fashion, all 2298 -- its uses can refer to specific bounds. 2299 2300 Set_Ekind (Id, K); 2301 Set_Etype (Id, T); 2302 2303 if (Is_Array_Type (T) and then not Is_Constrained (T)) 2304 or else (Ekind (T) = E_Record_Type and then Has_Discriminants (T)) 2305 then 2306 declare 2307 Non_Freezing_Ref : constant Node_Id := 2308 New_Occurrence_Of (Id, Sloc (Id)); 2309 Decl : Node_Id; 2310 2311 begin 2312 -- Make sure the actual subtype doesn't generate bogus freezing 2313 2314 Set_Must_Not_Freeze (Non_Freezing_Ref); 2315 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2316 Insert_Before_And_Analyze (N, Decl); 2317 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2318 end; 2319 else 2320 Set_Actual_Subtype (Id, T); 2321 end if; 2322 2323 if Present (E) then 2324 Error_Msg_N 2325 ("initialization not allowed for `IN OUT` formals", N); 2326 end if; 2327 end if; 2328 2329 if Has_Aspects (N) then 2330 Analyze_Aspect_Specifications (N, Id); 2331 end if; 2332 end Analyze_Formal_Object_Declaration; 2333 2334 ---------------------------------------------- 2335 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2336 ---------------------------------------------- 2337 2338 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2339 (T : Entity_Id; 2340 Def : Node_Id) 2341 is 2342 Loc : constant Source_Ptr := Sloc (Def); 2343 Base : constant Entity_Id := 2344 New_Internal_Entity 2345 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2346 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2347 2348 begin 2349 -- The semantic attributes are set for completeness only, their values 2350 -- will never be used, since all properties of the type are non-static. 2351 2352 Enter_Name (T); 2353 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2354 Set_Etype (T, Base); 2355 Set_Size_Info (T, Standard_Integer); 2356 Set_RM_Size (T, RM_Size (Standard_Integer)); 2357 Set_Small_Value (T, Ureal_1); 2358 Set_Delta_Value (T, Ureal_1); 2359 Set_Scalar_Range (T, 2360 Make_Range (Loc, 2361 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2362 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2363 Set_Is_Constrained (T); 2364 2365 Set_Is_Generic_Type (Base); 2366 Set_Etype (Base, Base); 2367 Set_Size_Info (Base, Standard_Integer); 2368 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2369 Set_Small_Value (Base, Ureal_1); 2370 Set_Delta_Value (Base, Ureal_1); 2371 Set_Scalar_Range (Base, Scalar_Range (T)); 2372 Set_Parent (Base, Parent (Def)); 2373 2374 Check_Restriction (No_Fixed_Point, Def); 2375 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2376 2377 ---------------------------------------- 2378 -- Analyze_Formal_Package_Declaration -- 2379 ---------------------------------------- 2380 2381 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2382 Gen_Id : constant Node_Id := Name (N); 2383 Loc : constant Source_Ptr := Sloc (N); 2384 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2385 Formal : Entity_Id; 2386 Gen_Decl : Node_Id; 2387 Gen_Unit : Entity_Id; 2388 Renaming : Node_Id; 2389 2390 Vis_Prims_List : Elist_Id := No_Elist; 2391 -- List of primitives made temporarily visible in the instantiation 2392 -- to match the visibility of the formal type. 2393 2394 function Build_Local_Package return Node_Id; 2395 -- The formal package is rewritten so that its parameters are replaced 2396 -- with corresponding declarations. For parameters with bona fide 2397 -- associations these declarations are created by Analyze_Associations 2398 -- as for a regular instantiation. For boxed parameters, we preserve 2399 -- the formal declarations and analyze them, in order to introduce 2400 -- entities of the right kind in the environment of the formal. 2401 2402 ------------------------- 2403 -- Build_Local_Package -- 2404 ------------------------- 2405 2406 function Build_Local_Package return Node_Id is 2407 Decls : List_Id; 2408 Pack_Decl : Node_Id; 2409 2410 begin 2411 -- Within the formal, the name of the generic package is a renaming 2412 -- of the formal (as for a regular instantiation). 2413 2414 Pack_Decl := 2415 Make_Package_Declaration (Loc, 2416 Specification => 2417 Copy_Generic_Node 2418 (Specification (Original_Node (Gen_Decl)), 2419 Empty, Instantiating => True)); 2420 2421 Renaming := 2422 Make_Package_Renaming_Declaration (Loc, 2423 Defining_Unit_Name => 2424 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2425 Name => New_Occurrence_Of (Formal, Loc)); 2426 2427 if Nkind (Gen_Id) = N_Identifier 2428 and then Chars (Gen_Id) = Chars (Pack_Id) 2429 then 2430 Error_Msg_NE 2431 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2432 end if; 2433 2434 -- If the formal is declared with a box, or with an others choice, 2435 -- create corresponding declarations for all entities in the formal 2436 -- part, so that names with the proper types are available in the 2437 -- specification of the formal package. 2438 2439 -- On the other hand, if there are no associations, then all the 2440 -- formals must have defaults, and this will be checked by the 2441 -- call to Analyze_Associations. 2442 2443 if Box_Present (N) 2444 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2445 then 2446 declare 2447 Formal_Decl : Node_Id; 2448 2449 begin 2450 -- TBA : for a formal package, need to recurse ??? 2451 2452 Decls := New_List; 2453 Formal_Decl := 2454 First 2455 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2456 while Present (Formal_Decl) loop 2457 Append_To 2458 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True)); 2459 Next (Formal_Decl); 2460 end loop; 2461 end; 2462 2463 -- If generic associations are present, use Analyze_Associations to 2464 -- create the proper renaming declarations. 2465 2466 else 2467 declare 2468 Act_Tree : constant Node_Id := 2469 Copy_Generic_Node 2470 (Original_Node (Gen_Decl), Empty, 2471 Instantiating => True); 2472 2473 begin 2474 Generic_Renamings.Set_Last (0); 2475 Generic_Renamings_HTable.Reset; 2476 Instantiation_Node := N; 2477 2478 Decls := 2479 Analyze_Associations 2480 (I_Node => Original_Node (N), 2481 Formals => Generic_Formal_Declarations (Act_Tree), 2482 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2483 2484 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2485 end; 2486 end if; 2487 2488 Append (Renaming, To => Decls); 2489 2490 -- Add generated declarations ahead of local declarations in 2491 -- the package. 2492 2493 if No (Visible_Declarations (Specification (Pack_Decl))) then 2494 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2495 else 2496 Insert_List_Before 2497 (First (Visible_Declarations (Specification (Pack_Decl))), 2498 Decls); 2499 end if; 2500 2501 return Pack_Decl; 2502 end Build_Local_Package; 2503 2504 -- Local variables 2505 2506 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; 2507 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit 2508 2509 Associations : Boolean := True; 2510 New_N : Node_Id; 2511 Parent_Installed : Boolean := False; 2512 Parent_Instance : Entity_Id; 2513 Renaming_In_Par : Entity_Id; 2514 2515 -- Start of processing for Analyze_Formal_Package_Declaration 2516 2517 begin 2518 Check_Text_IO_Special_Unit (Gen_Id); 2519 2520 Init_Env; 2521 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2522 Gen_Unit := Entity (Gen_Id); 2523 2524 -- Check for a formal package that is a package renaming 2525 2526 if Present (Renamed_Object (Gen_Unit)) then 2527 2528 -- Indicate that unit is used, before replacing it with renamed 2529 -- entity for use below. 2530 2531 if In_Extended_Main_Source_Unit (N) then 2532 Set_Is_Instantiated (Gen_Unit); 2533 Generate_Reference (Gen_Unit, N); 2534 end if; 2535 2536 Gen_Unit := Renamed_Object (Gen_Unit); 2537 end if; 2538 2539 if Ekind (Gen_Unit) /= E_Generic_Package then 2540 Error_Msg_N ("expect generic package name", Gen_Id); 2541 Restore_Env; 2542 goto Leave; 2543 2544 elsif Gen_Unit = Current_Scope then 2545 Error_Msg_N 2546 ("generic package cannot be used as a formal package of itself", 2547 Gen_Id); 2548 Restore_Env; 2549 goto Leave; 2550 2551 elsif In_Open_Scopes (Gen_Unit) then 2552 if Is_Compilation_Unit (Gen_Unit) 2553 and then Is_Child_Unit (Current_Scope) 2554 then 2555 -- Special-case the error when the formal is a parent, and 2556 -- continue analysis to minimize cascaded errors. 2557 2558 Error_Msg_N 2559 ("generic parent cannot be used as formal package " 2560 & "of a child unit", Gen_Id); 2561 2562 else 2563 Error_Msg_N 2564 ("generic package cannot be used as a formal package " 2565 & "within itself", Gen_Id); 2566 Restore_Env; 2567 goto Leave; 2568 end if; 2569 end if; 2570 2571 -- Check that name of formal package does not hide name of generic, 2572 -- or its leading prefix. This check must be done separately because 2573 -- the name of the generic has already been analyzed. 2574 2575 declare 2576 Gen_Name : Entity_Id; 2577 2578 begin 2579 Gen_Name := Gen_Id; 2580 while Nkind (Gen_Name) = N_Expanded_Name loop 2581 Gen_Name := Prefix (Gen_Name); 2582 end loop; 2583 2584 if Chars (Gen_Name) = Chars (Pack_Id) then 2585 Error_Msg_NE 2586 ("& is hidden within declaration of formal package", 2587 Gen_Id, Gen_Name); 2588 end if; 2589 end; 2590 2591 if Box_Present (N) 2592 or else No (Generic_Associations (N)) 2593 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2594 then 2595 Associations := False; 2596 end if; 2597 2598 -- If there are no generic associations, the generic parameters appear 2599 -- as local entities and are instantiated like them. We copy the generic 2600 -- package declaration as if it were an instantiation, and analyze it 2601 -- like a regular package, except that we treat the formals as 2602 -- additional visible components. 2603 2604 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2605 2606 if In_Extended_Main_Source_Unit (N) then 2607 Set_Is_Instantiated (Gen_Unit); 2608 Generate_Reference (Gen_Unit, N); 2609 end if; 2610 2611 Formal := New_Copy (Pack_Id); 2612 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 2613 2614 -- Make local generic without formals. The formals will be replaced with 2615 -- internal declarations. 2616 2617 begin 2618 New_N := Build_Local_Package; 2619 2620 -- If there are errors in the parameter list, Analyze_Associations 2621 -- raises Instantiation_Error. Patch the declaration to prevent further 2622 -- exception propagation. 2623 2624 exception 2625 when Instantiation_Error => 2626 Enter_Name (Formal); 2627 Set_Ekind (Formal, E_Variable); 2628 Set_Etype (Formal, Any_Type); 2629 Restore_Hidden_Primitives (Vis_Prims_List); 2630 2631 if Parent_Installed then 2632 Remove_Parent; 2633 end if; 2634 2635 goto Leave; 2636 end; 2637 2638 Rewrite (N, New_N); 2639 Set_Defining_Unit_Name (Specification (New_N), Formal); 2640 Set_Generic_Parent (Specification (N), Gen_Unit); 2641 Set_Instance_Env (Gen_Unit, Formal); 2642 Set_Is_Generic_Instance (Formal); 2643 2644 Enter_Name (Formal); 2645 Set_Ekind (Formal, E_Package); 2646 Set_Etype (Formal, Standard_Void_Type); 2647 Set_Inner_Instances (Formal, New_Elmt_List); 2648 Push_Scope (Formal); 2649 2650 -- Manually set the SPARK_Mode from the context because the package 2651 -- declaration is never analyzed. 2652 2653 Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma); 2654 Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma); 2655 Set_SPARK_Pragma_Inherited (Formal); 2656 Set_SPARK_Aux_Pragma_Inherited (Formal); 2657 2658 if Is_Child_Unit (Gen_Unit) and then Parent_Installed then 2659 2660 -- Similarly, we have to make the name of the formal visible in the 2661 -- parent instance, to resolve properly fully qualified names that 2662 -- may appear in the generic unit. The parent instance has been 2663 -- placed on the scope stack ahead of the current scope. 2664 2665 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2666 2667 Renaming_In_Par := 2668 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2669 Set_Ekind (Renaming_In_Par, E_Package); 2670 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2671 Set_Scope (Renaming_In_Par, Parent_Instance); 2672 Set_Parent (Renaming_In_Par, Parent (Formal)); 2673 Set_Renamed_Object (Renaming_In_Par, Formal); 2674 Append_Entity (Renaming_In_Par, Parent_Instance); 2675 end if; 2676 2677 -- A formal package declaration behaves as a package instantiation with 2678 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether 2679 -- missing, set the global flag which signals Analyze_Pragma to ingnore 2680 -- all SPARK_Mode pragmas within the generic_package_name. 2681 2682 if SPARK_Mode /= On then 2683 Ignore_Pragma_SPARK_Mode := True; 2684 end if; 2685 2686 Analyze (Specification (N)); 2687 2688 -- The formals for which associations are provided are not visible 2689 -- outside of the formal package. The others are still declared by a 2690 -- formal parameter declaration. 2691 2692 -- If there are no associations, the only local entity to hide is the 2693 -- generated package renaming itself. 2694 2695 declare 2696 E : Entity_Id; 2697 2698 begin 2699 E := First_Entity (Formal); 2700 while Present (E) loop 2701 if Associations and then not Is_Generic_Formal (E) then 2702 Set_Is_Hidden (E); 2703 end if; 2704 2705 if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then 2706 Set_Is_Hidden (E); 2707 exit; 2708 end if; 2709 2710 Next_Entity (E); 2711 end loop; 2712 end; 2713 2714 End_Package_Scope (Formal); 2715 Restore_Hidden_Primitives (Vis_Prims_List); 2716 2717 if Parent_Installed then 2718 Remove_Parent; 2719 end if; 2720 2721 Restore_Env; 2722 2723 -- Inside the generic unit, the formal package is a regular package, but 2724 -- no body is needed for it. Note that after instantiation, the defining 2725 -- unit name we need is in the new tree and not in the original (see 2726 -- Package_Instantiation). A generic formal package is an instance, and 2727 -- can be used as an actual for an inner instance. 2728 2729 Set_Has_Completion (Formal, True); 2730 2731 -- Add semantic information to the original defining identifier for ASIS 2732 -- use. 2733 2734 Set_Ekind (Pack_Id, E_Package); 2735 Set_Etype (Pack_Id, Standard_Void_Type); 2736 Set_Scope (Pack_Id, Scope (Formal)); 2737 Set_Has_Completion (Pack_Id, True); 2738 2739 <<Leave>> 2740 if Has_Aspects (N) then 2741 Analyze_Aspect_Specifications (N, Pack_Id); 2742 end if; 2743 2744 Ignore_Pragma_SPARK_Mode := Save_IPSM; 2745 end Analyze_Formal_Package_Declaration; 2746 2747 --------------------------------- 2748 -- Analyze_Formal_Private_Type -- 2749 --------------------------------- 2750 2751 procedure Analyze_Formal_Private_Type 2752 (N : Node_Id; 2753 T : Entity_Id; 2754 Def : Node_Id) 2755 is 2756 begin 2757 New_Private_Type (N, T, Def); 2758 2759 -- Set the size to an arbitrary but legal value 2760 2761 Set_Size_Info (T, Standard_Integer); 2762 Set_RM_Size (T, RM_Size (Standard_Integer)); 2763 end Analyze_Formal_Private_Type; 2764 2765 ------------------------------------ 2766 -- Analyze_Formal_Incomplete_Type -- 2767 ------------------------------------ 2768 2769 procedure Analyze_Formal_Incomplete_Type 2770 (T : Entity_Id; 2771 Def : Node_Id) 2772 is 2773 begin 2774 Enter_Name (T); 2775 Set_Ekind (T, E_Incomplete_Type); 2776 Set_Etype (T, T); 2777 Set_Private_Dependents (T, New_Elmt_List); 2778 2779 if Tagged_Present (Def) then 2780 Set_Is_Tagged_Type (T); 2781 Make_Class_Wide_Type (T); 2782 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2783 end if; 2784 end Analyze_Formal_Incomplete_Type; 2785 2786 ---------------------------------------- 2787 -- Analyze_Formal_Signed_Integer_Type -- 2788 ---------------------------------------- 2789 2790 procedure Analyze_Formal_Signed_Integer_Type 2791 (T : Entity_Id; 2792 Def : Node_Id) 2793 is 2794 Base : constant Entity_Id := 2795 New_Internal_Entity 2796 (E_Signed_Integer_Type, 2797 Current_Scope, 2798 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2799 2800 begin 2801 Enter_Name (T); 2802 2803 Set_Ekind (T, E_Signed_Integer_Subtype); 2804 Set_Etype (T, Base); 2805 Set_Size_Info (T, Standard_Integer); 2806 Set_RM_Size (T, RM_Size (Standard_Integer)); 2807 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 2808 Set_Is_Constrained (T); 2809 2810 Set_Is_Generic_Type (Base); 2811 Set_Size_Info (Base, Standard_Integer); 2812 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2813 Set_Etype (Base, Base); 2814 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 2815 Set_Parent (Base, Parent (Def)); 2816 end Analyze_Formal_Signed_Integer_Type; 2817 2818 ------------------------------------------- 2819 -- Analyze_Formal_Subprogram_Declaration -- 2820 ------------------------------------------- 2821 2822 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 2823 Spec : constant Node_Id := Specification (N); 2824 Def : constant Node_Id := Default_Name (N); 2825 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 2826 Subp : Entity_Id; 2827 2828 begin 2829 if Nam = Error then 2830 return; 2831 end if; 2832 2833 if Nkind (Nam) = N_Defining_Program_Unit_Name then 2834 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 2835 goto Leave; 2836 end if; 2837 2838 Analyze_Subprogram_Declaration (N); 2839 Set_Is_Formal_Subprogram (Nam); 2840 Set_Has_Completion (Nam); 2841 2842 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 2843 Set_Is_Abstract_Subprogram (Nam); 2844 2845 Set_Is_Dispatching_Operation (Nam); 2846 2847 -- A formal abstract procedure cannot have a null default 2848 -- (RM 12.6(4.1/2)). 2849 2850 if Nkind (Spec) = N_Procedure_Specification 2851 and then Null_Present (Spec) 2852 then 2853 Error_Msg_N 2854 ("a formal abstract subprogram cannot default to null", Spec); 2855 end if; 2856 2857 declare 2858 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 2859 begin 2860 if No (Ctrl_Type) then 2861 Error_Msg_N 2862 ("abstract formal subprogram must have a controlling type", 2863 N); 2864 2865 elsif Ada_Version >= Ada_2012 2866 and then Is_Incomplete_Type (Ctrl_Type) 2867 then 2868 Error_Msg_NE 2869 ("controlling type of abstract formal subprogram cannot " 2870 & "be incomplete type", N, Ctrl_Type); 2871 2872 else 2873 Check_Controlling_Formals (Ctrl_Type, Nam); 2874 end if; 2875 end; 2876 end if; 2877 2878 -- Default name is resolved at the point of instantiation 2879 2880 if Box_Present (N) then 2881 null; 2882 2883 -- Else default is bound at the point of generic declaration 2884 2885 elsif Present (Def) then 2886 if Nkind (Def) = N_Operator_Symbol then 2887 Find_Direct_Name (Def); 2888 2889 elsif Nkind (Def) /= N_Attribute_Reference then 2890 Analyze (Def); 2891 2892 else 2893 -- For an attribute reference, analyze the prefix and verify 2894 -- that it has the proper profile for the subprogram. 2895 2896 Analyze (Prefix (Def)); 2897 Valid_Default_Attribute (Nam, Def); 2898 goto Leave; 2899 end if; 2900 2901 -- Default name may be overloaded, in which case the interpretation 2902 -- with the correct profile must be selected, as for a renaming. 2903 -- If the definition is an indexed component, it must denote a 2904 -- member of an entry family. If it is a selected component, it 2905 -- can be a protected operation. 2906 2907 if Etype (Def) = Any_Type then 2908 goto Leave; 2909 2910 elsif Nkind (Def) = N_Selected_Component then 2911 if not Is_Overloadable (Entity (Selector_Name (Def))) then 2912 Error_Msg_N ("expect valid subprogram name as default", Def); 2913 end if; 2914 2915 elsif Nkind (Def) = N_Indexed_Component then 2916 if Is_Entity_Name (Prefix (Def)) then 2917 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 2918 Error_Msg_N ("expect valid subprogram name as default", Def); 2919 end if; 2920 2921 elsif Nkind (Prefix (Def)) = N_Selected_Component then 2922 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 2923 E_Entry_Family 2924 then 2925 Error_Msg_N ("expect valid subprogram name as default", Def); 2926 end if; 2927 2928 else 2929 Error_Msg_N ("expect valid subprogram name as default", Def); 2930 goto Leave; 2931 end if; 2932 2933 elsif Nkind (Def) = N_Character_Literal then 2934 2935 -- Needs some type checks: subprogram should be parameterless??? 2936 2937 Resolve (Def, (Etype (Nam))); 2938 2939 elsif not Is_Entity_Name (Def) 2940 or else not Is_Overloadable (Entity (Def)) 2941 then 2942 Error_Msg_N ("expect valid subprogram name as default", Def); 2943 goto Leave; 2944 2945 elsif not Is_Overloaded (Def) then 2946 Subp := Entity (Def); 2947 2948 if Subp = Nam then 2949 Error_Msg_N ("premature usage of formal subprogram", Def); 2950 2951 elsif not Entity_Matches_Spec (Subp, Nam) then 2952 Error_Msg_N ("no visible entity matches specification", Def); 2953 end if; 2954 2955 -- More than one interpretation, so disambiguate as for a renaming 2956 2957 else 2958 declare 2959 I : Interp_Index; 2960 I1 : Interp_Index := 0; 2961 It : Interp; 2962 It1 : Interp; 2963 2964 begin 2965 Subp := Any_Id; 2966 Get_First_Interp (Def, I, It); 2967 while Present (It.Nam) loop 2968 if Entity_Matches_Spec (It.Nam, Nam) then 2969 if Subp /= Any_Id then 2970 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 2971 2972 if It1 = No_Interp then 2973 Error_Msg_N ("ambiguous default subprogram", Def); 2974 else 2975 Subp := It1.Nam; 2976 end if; 2977 2978 exit; 2979 2980 else 2981 I1 := I; 2982 Subp := It.Nam; 2983 end if; 2984 end if; 2985 2986 Get_Next_Interp (I, It); 2987 end loop; 2988 end; 2989 2990 if Subp /= Any_Id then 2991 2992 -- Subprogram found, generate reference to it 2993 2994 Set_Entity (Def, Subp); 2995 Generate_Reference (Subp, Def); 2996 2997 if Subp = Nam then 2998 Error_Msg_N ("premature usage of formal subprogram", Def); 2999 3000 elsif Ekind (Subp) /= E_Operator then 3001 Check_Mode_Conformant (Subp, Nam); 3002 end if; 3003 3004 else 3005 Error_Msg_N ("no visible subprogram matches specification", N); 3006 end if; 3007 end if; 3008 end if; 3009 3010 <<Leave>> 3011 if Has_Aspects (N) then 3012 Analyze_Aspect_Specifications (N, Nam); 3013 end if; 3014 3015 end Analyze_Formal_Subprogram_Declaration; 3016 3017 ------------------------------------- 3018 -- Analyze_Formal_Type_Declaration -- 3019 ------------------------------------- 3020 3021 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 3022 Def : constant Node_Id := Formal_Type_Definition (N); 3023 T : Entity_Id; 3024 3025 begin 3026 T := Defining_Identifier (N); 3027 3028 if Present (Discriminant_Specifications (N)) 3029 and then Nkind (Def) /= N_Formal_Private_Type_Definition 3030 then 3031 Error_Msg_N 3032 ("discriminants not allowed for this formal type", T); 3033 end if; 3034 3035 -- Enter the new name, and branch to specific routine 3036 3037 case Nkind (Def) is 3038 when N_Formal_Private_Type_Definition => 3039 Analyze_Formal_Private_Type (N, T, Def); 3040 3041 when N_Formal_Derived_Type_Definition => 3042 Analyze_Formal_Derived_Type (N, T, Def); 3043 3044 when N_Formal_Incomplete_Type_Definition => 3045 Analyze_Formal_Incomplete_Type (T, Def); 3046 3047 when N_Formal_Discrete_Type_Definition => 3048 Analyze_Formal_Discrete_Type (T, Def); 3049 3050 when N_Formal_Signed_Integer_Type_Definition => 3051 Analyze_Formal_Signed_Integer_Type (T, Def); 3052 3053 when N_Formal_Modular_Type_Definition => 3054 Analyze_Formal_Modular_Type (T, Def); 3055 3056 when N_Formal_Floating_Point_Definition => 3057 Analyze_Formal_Floating_Type (T, Def); 3058 3059 when N_Formal_Ordinary_Fixed_Point_Definition => 3060 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 3061 3062 when N_Formal_Decimal_Fixed_Point_Definition => 3063 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 3064 3065 when N_Array_Type_Definition => 3066 Analyze_Formal_Array_Type (T, Def); 3067 3068 when N_Access_To_Object_Definition | 3069 N_Access_Function_Definition | 3070 N_Access_Procedure_Definition => 3071 Analyze_Generic_Access_Type (T, Def); 3072 3073 -- Ada 2005: a interface declaration is encoded as an abstract 3074 -- record declaration or a abstract type derivation. 3075 3076 when N_Record_Definition => 3077 Analyze_Formal_Interface_Type (N, T, Def); 3078 3079 when N_Derived_Type_Definition => 3080 Analyze_Formal_Derived_Interface_Type (N, T, Def); 3081 3082 when N_Error => 3083 null; 3084 3085 when others => 3086 raise Program_Error; 3087 3088 end case; 3089 3090 Set_Is_Generic_Type (T); 3091 3092 if Has_Aspects (N) then 3093 Analyze_Aspect_Specifications (N, T); 3094 end if; 3095 end Analyze_Formal_Type_Declaration; 3096 3097 ------------------------------------ 3098 -- Analyze_Function_Instantiation -- 3099 ------------------------------------ 3100 3101 procedure Analyze_Function_Instantiation (N : Node_Id) is 3102 begin 3103 Analyze_Subprogram_Instantiation (N, E_Function); 3104 end Analyze_Function_Instantiation; 3105 3106 --------------------------------- 3107 -- Analyze_Generic_Access_Type -- 3108 --------------------------------- 3109 3110 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 3111 begin 3112 Enter_Name (T); 3113 3114 if Nkind (Def) = N_Access_To_Object_Definition then 3115 Access_Type_Declaration (T, Def); 3116 3117 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 3118 and then No (Full_View (Designated_Type (T))) 3119 and then not Is_Generic_Type (Designated_Type (T)) 3120 then 3121 Error_Msg_N ("premature usage of incomplete type", Def); 3122 3123 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 3124 Error_Msg_N 3125 ("only a subtype mark is allowed in a formal", Def); 3126 end if; 3127 3128 else 3129 Access_Subprogram_Declaration (T, Def); 3130 end if; 3131 end Analyze_Generic_Access_Type; 3132 3133 --------------------------------- 3134 -- Analyze_Generic_Formal_Part -- 3135 --------------------------------- 3136 3137 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 3138 Gen_Parm_Decl : Node_Id; 3139 3140 begin 3141 -- The generic formals are processed in the scope of the generic unit, 3142 -- where they are immediately visible. The scope is installed by the 3143 -- caller. 3144 3145 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 3146 while Present (Gen_Parm_Decl) loop 3147 Analyze (Gen_Parm_Decl); 3148 Next (Gen_Parm_Decl); 3149 end loop; 3150 3151 Generate_Reference_To_Generic_Formals (Current_Scope); 3152 end Analyze_Generic_Formal_Part; 3153 3154 ------------------------------------------ 3155 -- Analyze_Generic_Package_Declaration -- 3156 ------------------------------------------ 3157 3158 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 3159 Loc : constant Source_Ptr := Sloc (N); 3160 Decls : constant List_Id := 3161 Visible_Declarations (Specification (N)); 3162 Decl : Node_Id; 3163 Id : Entity_Id; 3164 New_N : Node_Id; 3165 Renaming : Node_Id; 3166 Save_Parent : Node_Id; 3167 3168 begin 3169 Check_SPARK_05_Restriction ("generic is not allowed", N); 3170 3171 -- We introduce a renaming of the enclosing package, to have a usable 3172 -- entity as the prefix of an expanded name for a local entity of the 3173 -- form Par.P.Q, where P is the generic package. This is because a local 3174 -- entity named P may hide it, so that the usual visibility rules in 3175 -- the instance will not resolve properly. 3176 3177 Renaming := 3178 Make_Package_Renaming_Declaration (Loc, 3179 Defining_Unit_Name => 3180 Make_Defining_Identifier (Loc, 3181 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 3182 Name => 3183 Make_Identifier (Loc, Chars (Defining_Entity (N)))); 3184 3185 if Present (Decls) then 3186 Decl := First (Decls); 3187 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 3188 Next (Decl); 3189 end loop; 3190 3191 if Present (Decl) then 3192 Insert_Before (Decl, Renaming); 3193 else 3194 Append (Renaming, Visible_Declarations (Specification (N))); 3195 end if; 3196 3197 else 3198 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3199 end if; 3200 3201 -- Create copy of generic unit, and save for instantiation. If the unit 3202 -- is a child unit, do not copy the specifications for the parent, which 3203 -- are not part of the generic tree. 3204 3205 Save_Parent := Parent_Spec (N); 3206 Set_Parent_Spec (N, Empty); 3207 3208 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3209 Set_Parent_Spec (New_N, Save_Parent); 3210 Rewrite (N, New_N); 3211 3212 -- Once the contents of the generic copy and the template are swapped, 3213 -- do the same for their respective aspect specifications. 3214 3215 Exchange_Aspects (N, New_N); 3216 3217 -- Collect all contract-related source pragmas found within the template 3218 -- and attach them to the contract of the package spec. This contract is 3219 -- used in the capture of global references within annotations. 3220 3221 Create_Generic_Contract (N); 3222 3223 Id := Defining_Entity (N); 3224 Generate_Definition (Id); 3225 3226 -- Expansion is not applied to generic units 3227 3228 Start_Generic; 3229 3230 Enter_Name (Id); 3231 Set_Ekind (Id, E_Generic_Package); 3232 Set_Etype (Id, Standard_Void_Type); 3233 3234 -- A generic package declared within a Ghost region is rendered Ghost 3235 -- (SPARK RM 6.9(2)). 3236 3237 if Ghost_Mode > None then 3238 Set_Is_Ghost_Entity (Id); 3239 end if; 3240 3241 -- Analyze aspects now, so that generated pragmas appear in the 3242 -- declarations before building and analyzing the generic copy. 3243 3244 if Has_Aspects (N) then 3245 Analyze_Aspect_Specifications (N, Id); 3246 end if; 3247 3248 Push_Scope (Id); 3249 Enter_Generic_Scope (Id); 3250 Set_Inner_Instances (Id, New_Elmt_List); 3251 3252 Set_Categorization_From_Pragmas (N); 3253 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3254 3255 -- Link the declaration of the generic homonym in the generic copy to 3256 -- the package it renames, so that it is always resolved properly. 3257 3258 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3259 Set_Entity (Associated_Node (Name (Renaming)), Id); 3260 3261 -- For a library unit, we have reconstructed the entity for the unit, 3262 -- and must reset it in the library tables. 3263 3264 if Nkind (Parent (N)) = N_Compilation_Unit then 3265 Set_Cunit_Entity (Current_Sem_Unit, Id); 3266 end if; 3267 3268 Analyze_Generic_Formal_Part (N); 3269 3270 -- After processing the generic formals, analysis proceeds as for a 3271 -- non-generic package. 3272 3273 Analyze (Specification (N)); 3274 3275 Validate_Categorization_Dependency (N, Id); 3276 3277 End_Generic; 3278 3279 End_Package_Scope (Id); 3280 Exit_Generic_Scope (Id); 3281 3282 if Nkind (Parent (N)) /= N_Compilation_Unit then 3283 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3284 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3285 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3286 3287 else 3288 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3289 Validate_RT_RAT_Component (N); 3290 3291 -- If this is a spec without a body, check that generic parameters 3292 -- are referenced. 3293 3294 if not Body_Required (Parent (N)) then 3295 Check_References (Id); 3296 end if; 3297 end if; 3298 3299 -- If there is a specified storage pool in the context, create an 3300 -- aspect on the package declaration, so that it is used in any 3301 -- instance that does not override it. 3302 3303 if Present (Default_Pool) then 3304 declare 3305 ASN : Node_Id; 3306 3307 begin 3308 ASN := 3309 Make_Aspect_Specification (Loc, 3310 Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), 3311 Expression => New_Copy (Default_Pool)); 3312 3313 if No (Aspect_Specifications (Specification (N))) then 3314 Set_Aspect_Specifications (Specification (N), New_List (ASN)); 3315 else 3316 Append (ASN, Aspect_Specifications (Specification (N))); 3317 end if; 3318 end; 3319 end if; 3320 end Analyze_Generic_Package_Declaration; 3321 3322 -------------------------------------------- 3323 -- Analyze_Generic_Subprogram_Declaration -- 3324 -------------------------------------------- 3325 3326 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3327 Formals : List_Id; 3328 Id : Entity_Id; 3329 New_N : Node_Id; 3330 Result_Type : Entity_Id; 3331 Save_Parent : Node_Id; 3332 Spec : Node_Id; 3333 Typ : Entity_Id; 3334 3335 begin 3336 Check_SPARK_05_Restriction ("generic is not allowed", N); 3337 3338 -- Create copy of generic unit, and save for instantiation. If the unit 3339 -- is a child unit, do not copy the specifications for the parent, which 3340 -- are not part of the generic tree. 3341 3342 Save_Parent := Parent_Spec (N); 3343 Set_Parent_Spec (N, Empty); 3344 3345 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3346 Set_Parent_Spec (New_N, Save_Parent); 3347 Rewrite (N, New_N); 3348 3349 -- Once the contents of the generic copy and the template are swapped, 3350 -- do the same for their respective aspect specifications. 3351 3352 Exchange_Aspects (N, New_N); 3353 3354 -- Collect all contract-related source pragmas found within the template 3355 -- and attach them to the contract of the subprogram spec. This contract 3356 -- is used in the capture of global references within annotations. 3357 3358 Create_Generic_Contract (N); 3359 3360 Spec := Specification (N); 3361 Id := Defining_Entity (Spec); 3362 Generate_Definition (Id); 3363 3364 if Nkind (Id) = N_Defining_Operator_Symbol then 3365 Error_Msg_N 3366 ("operator symbol not allowed for generic subprogram", Id); 3367 end if; 3368 3369 Start_Generic; 3370 3371 Enter_Name (Id); 3372 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3373 3374 -- Analyze the aspects of the generic copy to ensure that all generated 3375 -- pragmas (if any) perform their semantic effects. 3376 3377 if Has_Aspects (N) then 3378 Analyze_Aspect_Specifications (N, Id); 3379 end if; 3380 3381 Push_Scope (Id); 3382 Enter_Generic_Scope (Id); 3383 Set_Inner_Instances (Id, New_Elmt_List); 3384 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3385 3386 Analyze_Generic_Formal_Part (N); 3387 3388 Formals := Parameter_Specifications (Spec); 3389 3390 if Nkind (Spec) = N_Function_Specification then 3391 Set_Ekind (Id, E_Generic_Function); 3392 else 3393 Set_Ekind (Id, E_Generic_Procedure); 3394 end if; 3395 3396 if Present (Formals) then 3397 Process_Formals (Formals, Spec); 3398 end if; 3399 3400 if Nkind (Spec) = N_Function_Specification then 3401 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3402 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3403 Set_Etype (Id, Result_Type); 3404 3405 -- Check restriction imposed by AI05-073: a generic function 3406 -- cannot return an abstract type or an access to such. 3407 3408 -- This is a binding interpretation should it apply to earlier 3409 -- versions of Ada as well as Ada 2012??? 3410 3411 if Is_Abstract_Type (Designated_Type (Result_Type)) 3412 and then Ada_Version >= Ada_2012 3413 then 3414 Error_Msg_N 3415 ("generic function cannot have an access result " 3416 & "that designates an abstract type", Spec); 3417 end if; 3418 3419 else 3420 Find_Type (Result_Definition (Spec)); 3421 Typ := Entity (Result_Definition (Spec)); 3422 3423 if Is_Abstract_Type (Typ) 3424 and then Ada_Version >= Ada_2012 3425 then 3426 Error_Msg_N 3427 ("generic function cannot have abstract result type", Spec); 3428 end if; 3429 3430 -- If a null exclusion is imposed on the result type, then create 3431 -- a null-excluding itype (an access subtype) and use it as the 3432 -- function's Etype. 3433 3434 if Is_Access_Type (Typ) 3435 and then Null_Exclusion_Present (Spec) 3436 then 3437 Set_Etype (Id, 3438 Create_Null_Excluding_Itype 3439 (T => Typ, 3440 Related_Nod => Spec, 3441 Scope_Id => Defining_Unit_Name (Spec))); 3442 else 3443 Set_Etype (Id, Typ); 3444 end if; 3445 end if; 3446 3447 else 3448 Set_Etype (Id, Standard_Void_Type); 3449 end if; 3450 3451 -- A generic subprogram declared within a Ghost region is rendered Ghost 3452 -- (SPARK RM 6.9(2)). 3453 3454 if Ghost_Mode > None then 3455 Set_Is_Ghost_Entity (Id); 3456 end if; 3457 3458 -- For a library unit, we have reconstructed the entity for the unit, 3459 -- and must reset it in the library tables. We also make sure that 3460 -- Body_Required is set properly in the original compilation unit node. 3461 3462 if Nkind (Parent (N)) = N_Compilation_Unit then 3463 Set_Cunit_Entity (Current_Sem_Unit, Id); 3464 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3465 end if; 3466 3467 Set_Categorization_From_Pragmas (N); 3468 Validate_Categorization_Dependency (N, Id); 3469 3470 -- Capture all global references that occur within the profile of the 3471 -- generic subprogram. Aspects are not part of this processing because 3472 -- they must be delayed. If processed now, Save_Global_References will 3473 -- destroy the Associated_Node links and prevent the capture of global 3474 -- references when the contract of the generic subprogram is analyzed. 3475 3476 Save_Global_References (Original_Node (N)); 3477 3478 End_Generic; 3479 End_Scope; 3480 Exit_Generic_Scope (Id); 3481 Generate_Reference_To_Formals (Id); 3482 3483 List_Inherited_Pre_Post_Aspects (Id); 3484 end Analyze_Generic_Subprogram_Declaration; 3485 3486 ----------------------------------- 3487 -- Analyze_Package_Instantiation -- 3488 ----------------------------------- 3489 3490 procedure Analyze_Package_Instantiation (N : Node_Id) is 3491 Loc : constant Source_Ptr := Sloc (N); 3492 Gen_Id : constant Node_Id := Name (N); 3493 3494 Act_Decl : Node_Id; 3495 Act_Decl_Name : Node_Id; 3496 Act_Decl_Id : Entity_Id; 3497 Act_Spec : Node_Id; 3498 Act_Tree : Node_Id; 3499 3500 Gen_Decl : Node_Id; 3501 Gen_Spec : Node_Id; 3502 Gen_Unit : Entity_Id; 3503 3504 Is_Actual_Pack : constant Boolean := 3505 Is_Internal (Defining_Entity (N)); 3506 3507 Env_Installed : Boolean := False; 3508 Parent_Installed : Boolean := False; 3509 Renaming_List : List_Id; 3510 Unit_Renaming : Node_Id; 3511 Needs_Body : Boolean; 3512 Inline_Now : Boolean := False; 3513 Has_Inline_Always : Boolean := False; 3514 3515 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; 3516 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit 3517 3518 Save_SM : constant SPARK_Mode_Type := SPARK_Mode; 3519 Save_SMP : constant Node_Id := SPARK_Mode_Pragma; 3520 -- Save the SPARK_Mode-related data for restore on exit 3521 3522 Save_Style_Check : constant Boolean := Style_Check; 3523 -- Save style check mode for restore on exit 3524 3525 procedure Delay_Descriptors (E : Entity_Id); 3526 -- Delay generation of subprogram descriptors for given entity 3527 3528 function Might_Inline_Subp return Boolean; 3529 -- If inlining is active and the generic contains inlined subprograms, 3530 -- we instantiate the body. This may cause superfluous instantiations, 3531 -- but it is simpler than detecting the need for the body at the point 3532 -- of inlining, when the context of the instance is not available. 3533 3534 ----------------------- 3535 -- Delay_Descriptors -- 3536 ----------------------- 3537 3538 procedure Delay_Descriptors (E : Entity_Id) is 3539 begin 3540 if not Delay_Subprogram_Descriptors (E) then 3541 Set_Delay_Subprogram_Descriptors (E); 3542 Pending_Descriptor.Append (E); 3543 end if; 3544 end Delay_Descriptors; 3545 3546 ----------------------- 3547 -- Might_Inline_Subp -- 3548 ----------------------- 3549 3550 function Might_Inline_Subp return Boolean is 3551 E : Entity_Id; 3552 3553 begin 3554 if not Inline_Processing_Required then 3555 return False; 3556 3557 else 3558 E := First_Entity (Gen_Unit); 3559 while Present (E) loop 3560 if Is_Subprogram (E) and then Is_Inlined (E) then 3561 -- Remember if there are any subprograms with Inline_Always 3562 3563 if Has_Pragma_Inline_Always (E) then 3564 Has_Inline_Always := True; 3565 end if; 3566 3567 return True; 3568 end if; 3569 3570 Next_Entity (E); 3571 end loop; 3572 end if; 3573 3574 return False; 3575 end Might_Inline_Subp; 3576 3577 -- Local declarations 3578 3579 Vis_Prims_List : Elist_Id := No_Elist; 3580 -- List of primitives made temporarily visible in the instantiation 3581 -- to match the visibility of the formal type 3582 3583 -- Start of processing for Analyze_Package_Instantiation 3584 3585 begin 3586 Check_SPARK_05_Restriction ("generic is not allowed", N); 3587 3588 -- Very first thing: check for Text_IO special unit in case we are 3589 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. 3590 3591 Check_Text_IO_Special_Unit (Name (N)); 3592 3593 -- Make node global for error reporting 3594 3595 Instantiation_Node := N; 3596 3597 -- Turn off style checking in instances. If the check is enabled on the 3598 -- generic unit, a warning in an instance would just be noise. If not 3599 -- enabled on the generic, then a warning in an instance is just wrong. 3600 3601 Style_Check := False; 3602 3603 -- Case of instantiation of a generic package 3604 3605 if Nkind (N) = N_Package_Instantiation then 3606 Act_Decl_Id := New_Copy (Defining_Entity (N)); 3607 Set_Comes_From_Source (Act_Decl_Id, True); 3608 3609 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 3610 Act_Decl_Name := 3611 Make_Defining_Program_Unit_Name (Loc, 3612 Name => 3613 New_Copy_Tree (Name (Defining_Unit_Name (N))), 3614 Defining_Identifier => Act_Decl_Id); 3615 else 3616 Act_Decl_Name := Act_Decl_Id; 3617 end if; 3618 3619 -- Case of instantiation of a formal package 3620 3621 else 3622 Act_Decl_Id := Defining_Identifier (N); 3623 Act_Decl_Name := Act_Decl_Id; 3624 end if; 3625 3626 Generate_Definition (Act_Decl_Id); 3627 Set_Ekind (Act_Decl_Id, E_Package); 3628 3629 -- Initialize list of incomplete actuals before analysis 3630 3631 Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List); 3632 3633 Preanalyze_Actuals (N, Act_Decl_Id); 3634 3635 Init_Env; 3636 Env_Installed := True; 3637 3638 -- Reset renaming map for formal types. The mapping is established 3639 -- when analyzing the generic associations, but some mappings are 3640 -- inherited from formal packages of parent units, and these are 3641 -- constructed when the parents are installed. 3642 3643 Generic_Renamings.Set_Last (0); 3644 Generic_Renamings_HTable.Reset; 3645 3646 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 3647 Gen_Unit := Entity (Gen_Id); 3648 3649 -- Verify that it is the name of a generic package 3650 3651 -- A visibility glitch: if the instance is a child unit and the generic 3652 -- is the generic unit of a parent instance (i.e. both the parent and 3653 -- the child units are instances of the same package) the name now 3654 -- denotes the renaming within the parent, not the intended generic 3655 -- unit. See if there is a homonym that is the desired generic. The 3656 -- renaming declaration must be visible inside the instance of the 3657 -- child, but not when analyzing the name in the instantiation itself. 3658 3659 if Ekind (Gen_Unit) = E_Package 3660 and then Present (Renamed_Entity (Gen_Unit)) 3661 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 3662 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 3663 and then Present (Homonym (Gen_Unit)) 3664 then 3665 Gen_Unit := Homonym (Gen_Unit); 3666 end if; 3667 3668 if Etype (Gen_Unit) = Any_Type then 3669 Restore_Env; 3670 goto Leave; 3671 3672 elsif Ekind (Gen_Unit) /= E_Generic_Package then 3673 3674 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 3675 3676 if From_Limited_With (Gen_Unit) then 3677 Error_Msg_N 3678 ("cannot instantiate a limited withed package", Gen_Id); 3679 else 3680 Error_Msg_NE 3681 ("& is not the name of a generic package", Gen_Id, Gen_Unit); 3682 end if; 3683 3684 Restore_Env; 3685 goto Leave; 3686 end if; 3687 3688 if In_Extended_Main_Source_Unit (N) then 3689 Set_Is_Instantiated (Gen_Unit); 3690 Generate_Reference (Gen_Unit, N); 3691 3692 if Present (Renamed_Object (Gen_Unit)) then 3693 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 3694 Generate_Reference (Renamed_Object (Gen_Unit), N); 3695 end if; 3696 end if; 3697 3698 if Nkind (Gen_Id) = N_Identifier 3699 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 3700 then 3701 Error_Msg_NE 3702 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 3703 3704 elsif Nkind (Gen_Id) = N_Expanded_Name 3705 and then Is_Child_Unit (Gen_Unit) 3706 and then Nkind (Prefix (Gen_Id)) = N_Identifier 3707 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 3708 then 3709 Error_Msg_N 3710 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 3711 end if; 3712 3713 Set_Entity (Gen_Id, Gen_Unit); 3714 3715 -- If generic is a renaming, get original generic unit 3716 3717 if Present (Renamed_Object (Gen_Unit)) 3718 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 3719 then 3720 Gen_Unit := Renamed_Object (Gen_Unit); 3721 end if; 3722 3723 -- Verify that there are no circular instantiations 3724 3725 if In_Open_Scopes (Gen_Unit) then 3726 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 3727 Restore_Env; 3728 goto Leave; 3729 3730 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 3731 Error_Msg_Node_2 := Current_Scope; 3732 Error_Msg_NE 3733 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 3734 Circularity_Detected := True; 3735 Restore_Env; 3736 goto Leave; 3737 3738 else 3739 -- If the context of the instance is subject to SPARK_Mode "off" or 3740 -- the annotation is altogether missing, set the global flag which 3741 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 3742 -- the instance. 3743 3744 if SPARK_Mode /= On then 3745 Ignore_Pragma_SPARK_Mode := True; 3746 end if; 3747 3748 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 3749 Gen_Spec := Specification (Gen_Decl); 3750 3751 -- Initialize renamings map, for error checking, and the list that 3752 -- holds private entities whose views have changed between generic 3753 -- definition and instantiation. If this is the instance created to 3754 -- validate an actual package, the instantiation environment is that 3755 -- of the enclosing instance. 3756 3757 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 3758 3759 -- Copy original generic tree, to produce text for instantiation 3760 3761 Act_Tree := 3762 Copy_Generic_Node 3763 (Original_Node (Gen_Decl), Empty, Instantiating => True); 3764 3765 Act_Spec := Specification (Act_Tree); 3766 3767 -- If this is the instance created to validate an actual package, 3768 -- only the formals matter, do not examine the package spec itself. 3769 3770 if Is_Actual_Pack then 3771 Set_Visible_Declarations (Act_Spec, New_List); 3772 Set_Private_Declarations (Act_Spec, New_List); 3773 end if; 3774 3775 Renaming_List := 3776 Analyze_Associations 3777 (I_Node => N, 3778 Formals => Generic_Formal_Declarations (Act_Tree), 3779 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 3780 3781 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 3782 3783 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 3784 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 3785 Set_Is_Generic_Instance (Act_Decl_Id); 3786 Set_Generic_Parent (Act_Spec, Gen_Unit); 3787 3788 -- References to the generic in its own declaration or its body are 3789 -- references to the instance. Add a renaming declaration for the 3790 -- generic unit itself. This declaration, as well as the renaming 3791 -- declarations for the generic formals, must remain private to the 3792 -- unit: the formals, because this is the language semantics, and 3793 -- the unit because its use is an artifact of the implementation. 3794 3795 Unit_Renaming := 3796 Make_Package_Renaming_Declaration (Loc, 3797 Defining_Unit_Name => 3798 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 3799 Name => New_Occurrence_Of (Act_Decl_Id, Loc)); 3800 3801 Append (Unit_Renaming, Renaming_List); 3802 3803 -- The renaming declarations are the first local declarations of the 3804 -- new unit. 3805 3806 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 3807 Insert_List_Before 3808 (First (Visible_Declarations (Act_Spec)), Renaming_List); 3809 else 3810 Set_Visible_Declarations (Act_Spec, Renaming_List); 3811 end if; 3812 3813 Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); 3814 3815 -- Propagate the aspect specifications from the package declaration 3816 -- template to the instantiated version of the package declaration. 3817 3818 if Has_Aspects (Act_Tree) then 3819 Set_Aspect_Specifications (Act_Decl, 3820 New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); 3821 end if; 3822 3823 -- The generic may have a generated Default_Storage_Pool aspect, 3824 -- set at the point of generic declaration. If the instance has 3825 -- that aspect, it overrides the one inherited from the generic. 3826 3827 if Has_Aspects (Gen_Spec) then 3828 if No (Aspect_Specifications (N)) then 3829 Set_Aspect_Specifications (N, 3830 (New_Copy_List_Tree 3831 (Aspect_Specifications (Gen_Spec)))); 3832 3833 else 3834 declare 3835 ASN1, ASN2 : Node_Id; 3836 3837 begin 3838 ASN1 := First (Aspect_Specifications (N)); 3839 while Present (ASN1) loop 3840 if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool 3841 then 3842 -- If generic carries a default storage pool, remove 3843 -- it in favor of the instance one. 3844 3845 ASN2 := First (Aspect_Specifications (Gen_Spec)); 3846 while Present (ASN2) loop 3847 if Chars (Identifier (ASN2)) = 3848 Name_Default_Storage_Pool 3849 then 3850 Remove (ASN2); 3851 exit; 3852 end if; 3853 3854 Next (ASN2); 3855 end loop; 3856 end if; 3857 3858 Next (ASN1); 3859 end loop; 3860 3861 Prepend_List_To (Aspect_Specifications (N), 3862 (New_Copy_List_Tree 3863 (Aspect_Specifications (Gen_Spec)))); 3864 end; 3865 end if; 3866 end if; 3867 3868 -- Save the instantiation node, for subsequent instantiation of the 3869 -- body, if there is one and we are generating code for the current 3870 -- unit. Mark unit as having a body (avoids premature error message). 3871 3872 -- We instantiate the body if we are generating code, if we are 3873 -- generating cross-reference information, or if we are building 3874 -- trees for ASIS use or GNATprove use. 3875 3876 declare 3877 Enclosing_Body_Present : Boolean := False; 3878 -- If the generic unit is not a compilation unit, then a body may 3879 -- be present in its parent even if none is required. We create a 3880 -- tentative pending instantiation for the body, which will be 3881 -- discarded if none is actually present. 3882 3883 Scop : Entity_Id; 3884 3885 begin 3886 if Scope (Gen_Unit) /= Standard_Standard 3887 and then not Is_Child_Unit (Gen_Unit) 3888 then 3889 Scop := Scope (Gen_Unit); 3890 while Present (Scop) and then Scop /= Standard_Standard loop 3891 if Unit_Requires_Body (Scop) then 3892 Enclosing_Body_Present := True; 3893 exit; 3894 3895 elsif In_Open_Scopes (Scop) 3896 and then In_Package_Body (Scop) 3897 then 3898 Enclosing_Body_Present := True; 3899 exit; 3900 end if; 3901 3902 exit when Is_Compilation_Unit (Scop); 3903 Scop := Scope (Scop); 3904 end loop; 3905 end if; 3906 3907 -- If front-end inlining is enabled or there are any subprograms 3908 -- marked with Inline_Always, and this is a unit for which code 3909 -- will be generated, we instantiate the body at once. 3910 3911 -- This is done if the instance is not the main unit, and if the 3912 -- generic is not a child unit of another generic, to avoid scope 3913 -- problems and the reinstallation of parent instances. 3914 3915 if Expander_Active 3916 and then (not Is_Child_Unit (Gen_Unit) 3917 or else not Is_Generic_Unit (Scope (Gen_Unit))) 3918 and then Might_Inline_Subp 3919 and then not Is_Actual_Pack 3920 then 3921 if not Back_End_Inlining 3922 and then (Front_End_Inlining or else Has_Inline_Always) 3923 and then (Is_In_Main_Unit (N) 3924 or else In_Main_Context (Current_Scope)) 3925 and then Nkind (Parent (N)) /= N_Compilation_Unit 3926 then 3927 Inline_Now := True; 3928 3929 -- In configurable_run_time mode we force the inlining of 3930 -- predefined subprograms marked Inline_Always, to minimize 3931 -- the use of the run-time library. 3932 3933 elsif Is_Predefined_File_Name 3934 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 3935 and then Configurable_Run_Time_Mode 3936 and then Nkind (Parent (N)) /= N_Compilation_Unit 3937 then 3938 Inline_Now := True; 3939 end if; 3940 3941 -- If the current scope is itself an instance within a child 3942 -- unit, there will be duplications in the scope stack, and the 3943 -- unstacking mechanism in Inline_Instance_Body will fail. 3944 -- This loses some rare cases of optimization, and might be 3945 -- improved some day, if we can find a proper abstraction for 3946 -- "the complete compilation context" that can be saved and 3947 -- restored. ??? 3948 3949 if Is_Generic_Instance (Current_Scope) then 3950 declare 3951 Curr_Unit : constant Entity_Id := 3952 Cunit_Entity (Current_Sem_Unit); 3953 begin 3954 if Curr_Unit /= Current_Scope 3955 and then Is_Child_Unit (Curr_Unit) 3956 then 3957 Inline_Now := False; 3958 end if; 3959 end; 3960 end if; 3961 end if; 3962 3963 Needs_Body := 3964 (Unit_Requires_Body (Gen_Unit) 3965 or else Enclosing_Body_Present 3966 or else Present (Corresponding_Body (Gen_Decl))) 3967 and then (Is_In_Main_Unit (N) or else Might_Inline_Subp) 3968 and then not Is_Actual_Pack 3969 and then not Inline_Now 3970 and then (Operating_Mode = Generate_Code 3971 3972 -- Need comment for this check ??? 3973 3974 or else (Operating_Mode = Check_Semantics 3975 and then (ASIS_Mode or GNATprove_Mode))); 3976 3977 -- If front-end inlining is enabled or there are any subprograms 3978 -- marked with Inline_Always, do not instantiate body when within 3979 -- a generic context. 3980 3981 if ((Front_End_Inlining or else Has_Inline_Always) 3982 and then not Expander_Active) 3983 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 3984 then 3985 Needs_Body := False; 3986 end if; 3987 3988 -- If the current context is generic, and the package being 3989 -- instantiated is declared within a formal package, there is no 3990 -- body to instantiate until the enclosing generic is instantiated 3991 -- and there is an actual for the formal package. If the formal 3992 -- package has parameters, we build a regular package instance for 3993 -- it, that precedes the original formal package declaration. 3994 3995 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 3996 declare 3997 Decl : constant Node_Id := 3998 Original_Node 3999 (Unit_Declaration_Node (Scope (Gen_Unit))); 4000 begin 4001 if Nkind (Decl) = N_Formal_Package_Declaration 4002 or else (Nkind (Decl) = N_Package_Declaration 4003 and then Is_List_Member (Decl) 4004 and then Present (Next (Decl)) 4005 and then 4006 Nkind (Next (Decl)) = 4007 N_Formal_Package_Declaration) 4008 then 4009 Needs_Body := False; 4010 end if; 4011 end; 4012 end if; 4013 end; 4014 4015 -- For RCI unit calling stubs, we omit the instance body if the 4016 -- instance is the RCI library unit itself. 4017 4018 -- However there is a special case for nested instances: in this case 4019 -- we do generate the instance body, as it might be required, e.g. 4020 -- because it provides stream attributes for some type used in the 4021 -- profile of a remote subprogram. This is consistent with 12.3(12), 4022 -- which indicates that the instance body occurs at the place of the 4023 -- instantiation, and thus is part of the RCI declaration, which is 4024 -- present on all client partitions (this is E.2.3(18)). 4025 4026 -- Note that AI12-0002 may make it illegal at some point to have 4027 -- stream attributes defined in an RCI unit, in which case this 4028 -- special case will become unnecessary. In the meantime, there 4029 -- is known application code in production that depends on this 4030 -- being possible, so we definitely cannot eliminate the body in 4031 -- the case of nested instances for the time being. 4032 4033 -- When we generate a nested instance body, calling stubs for any 4034 -- relevant subprogram will be be inserted immediately after the 4035 -- subprogram declarations, and will take precedence over the 4036 -- subsequent (original) body. (The stub and original body will be 4037 -- complete homographs, but this is permitted in an instance). 4038 -- (Could we do better and remove the original body???) 4039 4040 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 4041 and then Comes_From_Source (N) 4042 and then Nkind (Parent (N)) = N_Compilation_Unit 4043 then 4044 Needs_Body := False; 4045 end if; 4046 4047 if Needs_Body then 4048 4049 -- Here is a defence against a ludicrous number of instantiations 4050 -- caused by a circular set of instantiation attempts. 4051 4052 if Pending_Instantiations.Last > Maximum_Instantiations then 4053 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 4054 Error_Msg_N ("too many instantiations, exceeds max of^", N); 4055 Error_Msg_N ("\limit can be changed using -gnateinn switch", N); 4056 raise Unrecoverable_Error; 4057 end if; 4058 4059 -- Indicate that the enclosing scopes contain an instantiation, 4060 -- and that cleanup actions should be delayed until after the 4061 -- instance body is expanded. 4062 4063 Check_Forward_Instantiation (Gen_Decl); 4064 if Nkind (N) = N_Package_Instantiation then 4065 declare 4066 Enclosing_Master : Entity_Id; 4067 4068 begin 4069 -- Loop to search enclosing masters 4070 4071 Enclosing_Master := Current_Scope; 4072 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 4073 if Ekind (Enclosing_Master) = E_Package then 4074 if Is_Compilation_Unit (Enclosing_Master) then 4075 if In_Package_Body (Enclosing_Master) then 4076 Delay_Descriptors 4077 (Body_Entity (Enclosing_Master)); 4078 else 4079 Delay_Descriptors 4080 (Enclosing_Master); 4081 end if; 4082 4083 exit Scope_Loop; 4084 4085 else 4086 Enclosing_Master := Scope (Enclosing_Master); 4087 end if; 4088 4089 elsif Is_Generic_Unit (Enclosing_Master) 4090 or else Ekind (Enclosing_Master) = E_Void 4091 then 4092 -- Cleanup actions will eventually be performed on the 4093 -- enclosing subprogram or package instance, if any. 4094 -- Enclosing scope is void in the formal part of a 4095 -- generic subprogram. 4096 4097 exit Scope_Loop; 4098 4099 else 4100 if Ekind (Enclosing_Master) = E_Entry 4101 and then 4102 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 4103 then 4104 if not Expander_Active then 4105 exit Scope_Loop; 4106 else 4107 Enclosing_Master := 4108 Protected_Body_Subprogram (Enclosing_Master); 4109 end if; 4110 end if; 4111 4112 Set_Delay_Cleanups (Enclosing_Master); 4113 4114 while Ekind (Enclosing_Master) = E_Block loop 4115 Enclosing_Master := Scope (Enclosing_Master); 4116 end loop; 4117 4118 if Is_Subprogram (Enclosing_Master) then 4119 Delay_Descriptors (Enclosing_Master); 4120 4121 elsif Is_Task_Type (Enclosing_Master) then 4122 declare 4123 TBP : constant Node_Id := 4124 Get_Task_Body_Procedure 4125 (Enclosing_Master); 4126 begin 4127 if Present (TBP) then 4128 Delay_Descriptors (TBP); 4129 Set_Delay_Cleanups (TBP); 4130 end if; 4131 end; 4132 end if; 4133 4134 exit Scope_Loop; 4135 end if; 4136 end loop Scope_Loop; 4137 end; 4138 4139 -- Make entry in table 4140 4141 Pending_Instantiations.Append 4142 ((Inst_Node => N, 4143 Act_Decl => Act_Decl, 4144 Expander_Status => Expander_Active, 4145 Current_Sem_Unit => Current_Sem_Unit, 4146 Scope_Suppress => Scope_Suppress, 4147 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4148 Version => Ada_Version, 4149 Version_Pragma => Ada_Version_Pragma, 4150 Warnings => Save_Warnings, 4151 SPARK_Mode => SPARK_Mode, 4152 SPARK_Mode_Pragma => SPARK_Mode_Pragma)); 4153 end if; 4154 end if; 4155 4156 Set_Categorization_From_Pragmas (Act_Decl); 4157 4158 if Parent_Installed then 4159 Hide_Current_Scope; 4160 end if; 4161 4162 Set_Instance_Spec (N, Act_Decl); 4163 4164 -- If not a compilation unit, insert the package declaration before 4165 -- the original instantiation node. 4166 4167 if Nkind (Parent (N)) /= N_Compilation_Unit then 4168 Mark_Rewrite_Insertion (Act_Decl); 4169 Insert_Before (N, Act_Decl); 4170 4171 if Has_Aspects (N) then 4172 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4173 4174 -- The pragma created for a Default_Storage_Pool aspect must 4175 -- appear ahead of the declarations in the instance spec. 4176 -- Analysis has placed it after the instance node, so remove 4177 -- it and reinsert it properly now. 4178 4179 declare 4180 ASN : constant Node_Id := First (Aspect_Specifications (N)); 4181 A_Name : constant Name_Id := Chars (Identifier (ASN)); 4182 Decl : Node_Id; 4183 4184 begin 4185 if A_Name = Name_Default_Storage_Pool then 4186 if No (Visible_Declarations (Act_Spec)) then 4187 Set_Visible_Declarations (Act_Spec, New_List); 4188 end if; 4189 4190 Decl := Next (N); 4191 while Present (Decl) loop 4192 if Nkind (Decl) = N_Pragma then 4193 Remove (Decl); 4194 Prepend (Decl, Visible_Declarations (Act_Spec)); 4195 exit; 4196 end if; 4197 4198 Next (Decl); 4199 end loop; 4200 end if; 4201 end; 4202 end if; 4203 4204 Analyze (Act_Decl); 4205 4206 -- For an instantiation that is a compilation unit, place 4207 -- declaration on current node so context is complete for analysis 4208 -- (including nested instantiations). If this is the main unit, 4209 -- the declaration eventually replaces the instantiation node. 4210 -- If the instance body is created later, it replaces the 4211 -- instance node, and the declaration is attached to it 4212 -- (see Build_Instance_Compilation_Unit_Nodes). 4213 4214 else 4215 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 4216 4217 -- The entity for the current unit is the newly created one, 4218 -- and all semantic information is attached to it. 4219 4220 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 4221 4222 -- If this is the main unit, replace the main entity as well 4223 4224 if Current_Sem_Unit = Main_Unit then 4225 Main_Unit_Entity := Act_Decl_Id; 4226 end if; 4227 end if; 4228 4229 Set_Unit (Parent (N), Act_Decl); 4230 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 4231 Set_Package_Instantiation (Act_Decl_Id, N); 4232 4233 -- Process aspect specifications of the instance node, if any, to 4234 -- take into account categorization pragmas before analyzing the 4235 -- instance. 4236 4237 if Has_Aspects (N) then 4238 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4239 end if; 4240 4241 Analyze (Act_Decl); 4242 Set_Unit (Parent (N), N); 4243 Set_Body_Required (Parent (N), False); 4244 4245 -- We never need elaboration checks on instantiations, since by 4246 -- definition, the body instantiation is elaborated at the same 4247 -- time as the spec instantiation. 4248 4249 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4250 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4251 end if; 4252 4253 Check_Elab_Instantiation (N); 4254 4255 if ABE_Is_Certain (N) and then Needs_Body then 4256 Pending_Instantiations.Decrement_Last; 4257 end if; 4258 4259 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4260 4261 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 4262 First_Private_Entity (Act_Decl_Id)); 4263 4264 -- If the instantiation will receive a body, the unit will be 4265 -- transformed into a package body, and receive its own elaboration 4266 -- entity. Otherwise, the nature of the unit is now a package 4267 -- declaration. 4268 4269 if Nkind (Parent (N)) = N_Compilation_Unit 4270 and then not Needs_Body 4271 then 4272 Rewrite (N, Act_Decl); 4273 end if; 4274 4275 if Present (Corresponding_Body (Gen_Decl)) 4276 or else Unit_Requires_Body (Gen_Unit) 4277 then 4278 Set_Has_Completion (Act_Decl_Id); 4279 end if; 4280 4281 Check_Formal_Packages (Act_Decl_Id); 4282 4283 Restore_Hidden_Primitives (Vis_Prims_List); 4284 Restore_Private_Views (Act_Decl_Id); 4285 4286 Inherit_Context (Gen_Decl, N); 4287 4288 if Parent_Installed then 4289 Remove_Parent; 4290 end if; 4291 4292 Restore_Env; 4293 Env_Installed := False; 4294 end if; 4295 4296 Validate_Categorization_Dependency (N, Act_Decl_Id); 4297 4298 -- There used to be a check here to prevent instantiations in local 4299 -- contexts if the No_Local_Allocators restriction was active. This 4300 -- check was removed by a binding interpretation in AI-95-00130/07, 4301 -- but we retain the code for documentation purposes. 4302 4303 -- if Ekind (Act_Decl_Id) /= E_Void 4304 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4305 -- then 4306 -- Check_Restriction (No_Local_Allocators, N); 4307 -- end if; 4308 4309 if Inline_Now then 4310 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4311 end if; 4312 4313 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4314 -- be used as defining identifiers for a formal package and for the 4315 -- corresponding expanded package. 4316 4317 if Nkind (N) = N_Formal_Package_Declaration then 4318 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4319 Set_Comes_From_Source (Act_Decl_Id, True); 4320 Set_Is_Generic_Instance (Act_Decl_Id, False); 4321 Set_Defining_Identifier (N, Act_Decl_Id); 4322 end if; 4323 4324 Ignore_Pragma_SPARK_Mode := Save_IPSM; 4325 SPARK_Mode := Save_SM; 4326 SPARK_Mode_Pragma := Save_SMP; 4327 Style_Check := Save_Style_Check; 4328 4329 if SPARK_Mode = On then 4330 Dynamic_Elaboration_Checks := False; 4331 end if; 4332 4333 -- Check that if N is an instantiation of System.Dim_Float_IO or 4334 -- System.Dim_Integer_IO, the formal type has a dimension system. 4335 4336 if Nkind (N) = N_Package_Instantiation 4337 and then Is_Dim_IO_Package_Instantiation (N) 4338 then 4339 declare 4340 Assoc : constant Node_Id := First (Generic_Associations (N)); 4341 begin 4342 if not Has_Dimension_System 4343 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4344 then 4345 Error_Msg_N ("type with a dimension system expected", Assoc); 4346 end if; 4347 end; 4348 end if; 4349 4350 <<Leave>> 4351 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then 4352 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4353 end if; 4354 4355 exception 4356 when Instantiation_Error => 4357 if Parent_Installed then 4358 Remove_Parent; 4359 end if; 4360 4361 if Env_Installed then 4362 Restore_Env; 4363 end if; 4364 4365 Ignore_Pragma_SPARK_Mode := Save_IPSM; 4366 SPARK_Mode := Save_SM; 4367 SPARK_Mode_Pragma := Save_SMP; 4368 Style_Check := Save_Style_Check; 4369 4370 if SPARK_Mode = On then 4371 Dynamic_Elaboration_Checks := False; 4372 end if; 4373 end Analyze_Package_Instantiation; 4374 4375 -------------------------- 4376 -- Inline_Instance_Body -- 4377 -------------------------- 4378 4379 procedure Inline_Instance_Body 4380 (N : Node_Id; 4381 Gen_Unit : Entity_Id; 4382 Act_Decl : Node_Id) 4383 is 4384 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4385 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4386 Gen_Comp : constant Entity_Id := 4387 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4388 4389 Save_SM : constant SPARK_Mode_Type := SPARK_Mode; 4390 Save_SMP : constant Node_Id := SPARK_Mode_Pragma; 4391 -- Save all SPARK_Mode-related attributes as removing enclosing scopes 4392 -- to provide a clean environment for analysis of the inlined body will 4393 -- eliminate any previously set SPARK_Mode. 4394 4395 Scope_Stack_Depth : constant Int := 4396 Scope_Stack.Last - Scope_Stack.First + 1; 4397 4398 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4399 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4400 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4401 Curr_Scope : Entity_Id := Empty; 4402 List : Elist_Id; 4403 Num_Inner : Int := 0; 4404 Num_Scopes : Int := 0; 4405 N_Instances : Int := 0; 4406 Removed : Boolean := False; 4407 S : Entity_Id; 4408 Vis : Boolean; 4409 4410 begin 4411 -- Case of generic unit defined in another unit. We must remove the 4412 -- complete context of the current unit to install that of the generic. 4413 4414 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4415 4416 -- Add some comments for the following two loops ??? 4417 4418 S := Current_Scope; 4419 while Present (S) and then S /= Standard_Standard loop 4420 loop 4421 Num_Scopes := Num_Scopes + 1; 4422 4423 Use_Clauses (Num_Scopes) := 4424 (Scope_Stack.Table 4425 (Scope_Stack.Last - Num_Scopes + 1). 4426 First_Use_Clause); 4427 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4428 4429 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4430 or else Scope_Stack.Table 4431 (Scope_Stack.Last - Num_Scopes).Entity = Scope (S); 4432 end loop; 4433 4434 exit when Is_Generic_Instance (S) 4435 and then (In_Package_Body (S) 4436 or else Ekind (S) = E_Procedure 4437 or else Ekind (S) = E_Function); 4438 S := Scope (S); 4439 end loop; 4440 4441 Vis := Is_Immediately_Visible (Gen_Comp); 4442 4443 -- Find and save all enclosing instances 4444 4445 S := Current_Scope; 4446 4447 while Present (S) 4448 and then S /= Standard_Standard 4449 loop 4450 if Is_Generic_Instance (S) then 4451 N_Instances := N_Instances + 1; 4452 Instances (N_Instances) := S; 4453 4454 exit when In_Package_Body (S); 4455 end if; 4456 4457 S := Scope (S); 4458 end loop; 4459 4460 -- Remove context of current compilation unit, unless we are within a 4461 -- nested package instantiation, in which case the context has been 4462 -- removed previously. 4463 4464 -- If current scope is the body of a child unit, remove context of 4465 -- spec as well. If an enclosing scope is an instance body, the 4466 -- context has already been removed, but the entities in the body 4467 -- must be made invisible as well. 4468 4469 S := Current_Scope; 4470 while Present (S) and then S /= Standard_Standard loop 4471 if Is_Generic_Instance (S) 4472 and then (In_Package_Body (S) 4473 or else Ekind_In (S, E_Procedure, E_Function)) 4474 then 4475 -- We still have to remove the entities of the enclosing 4476 -- instance from direct visibility. 4477 4478 declare 4479 E : Entity_Id; 4480 begin 4481 E := First_Entity (S); 4482 while Present (E) loop 4483 Set_Is_Immediately_Visible (E, False); 4484 Next_Entity (E); 4485 end loop; 4486 end; 4487 4488 exit; 4489 end if; 4490 4491 if S = Curr_Unit 4492 or else (Ekind (Curr_Unit) = E_Package_Body 4493 and then S = Spec_Entity (Curr_Unit)) 4494 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4495 and then S = Corresponding_Spec 4496 (Unit_Declaration_Node (Curr_Unit))) 4497 then 4498 Removed := True; 4499 4500 -- Remove entities in current scopes from visibility, so that 4501 -- instance body is compiled in a clean environment. 4502 4503 List := Save_Scope_Stack (Handle_Use => False); 4504 4505 if Is_Child_Unit (S) then 4506 4507 -- Remove child unit from stack, as well as inner scopes. 4508 -- Removing the context of a child unit removes parent units 4509 -- as well. 4510 4511 while Current_Scope /= S loop 4512 Num_Inner := Num_Inner + 1; 4513 Inner_Scopes (Num_Inner) := Current_Scope; 4514 Pop_Scope; 4515 end loop; 4516 4517 Pop_Scope; 4518 Remove_Context (Curr_Comp); 4519 Curr_Scope := S; 4520 4521 else 4522 Remove_Context (Curr_Comp); 4523 end if; 4524 4525 if Ekind (Curr_Unit) = E_Package_Body then 4526 Remove_Context (Library_Unit (Curr_Comp)); 4527 end if; 4528 end if; 4529 4530 S := Scope (S); 4531 end loop; 4532 4533 pragma Assert (Num_Inner < Num_Scopes); 4534 4535 -- The inlined package body must be analyzed with the SPARK_Mode of 4536 -- the enclosing context, otherwise the body may cause bogus errors 4537 -- if a configuration SPARK_Mode pragma in in effect. 4538 4539 Push_Scope (Standard_Standard); 4540 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 4541 Instantiate_Package_Body 4542 (Body_Info => 4543 ((Inst_Node => N, 4544 Act_Decl => Act_Decl, 4545 Expander_Status => Expander_Active, 4546 Current_Sem_Unit => Current_Sem_Unit, 4547 Scope_Suppress => Scope_Suppress, 4548 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4549 Version => Ada_Version, 4550 Version_Pragma => Ada_Version_Pragma, 4551 Warnings => Save_Warnings, 4552 SPARK_Mode => Save_SM, 4553 SPARK_Mode_Pragma => Save_SMP)), 4554 Inlined_Body => True); 4555 4556 Pop_Scope; 4557 4558 -- Restore context 4559 4560 Set_Is_Immediately_Visible (Gen_Comp, Vis); 4561 4562 -- Reset Generic_Instance flag so that use clauses can be installed 4563 -- in the proper order. (See Use_One_Package for effect of enclosing 4564 -- instances on processing of use clauses). 4565 4566 for J in 1 .. N_Instances loop 4567 Set_Is_Generic_Instance (Instances (J), False); 4568 end loop; 4569 4570 if Removed then 4571 Install_Context (Curr_Comp); 4572 4573 if Present (Curr_Scope) 4574 and then Is_Child_Unit (Curr_Scope) 4575 then 4576 Push_Scope (Curr_Scope); 4577 Set_Is_Immediately_Visible (Curr_Scope); 4578 4579 -- Finally, restore inner scopes as well 4580 4581 for J in reverse 1 .. Num_Inner loop 4582 Push_Scope (Inner_Scopes (J)); 4583 end loop; 4584 end if; 4585 4586 Restore_Scope_Stack (List, Handle_Use => False); 4587 4588 if Present (Curr_Scope) 4589 and then 4590 (In_Private_Part (Curr_Scope) 4591 or else In_Package_Body (Curr_Scope)) 4592 then 4593 -- Install private declaration of ancestor units, which are 4594 -- currently available. Restore_Scope_Stack and Install_Context 4595 -- only install the visible part of parents. 4596 4597 declare 4598 Par : Entity_Id; 4599 begin 4600 Par := Scope (Curr_Scope); 4601 while (Present (Par)) and then Par /= Standard_Standard loop 4602 Install_Private_Declarations (Par); 4603 Par := Scope (Par); 4604 end loop; 4605 end; 4606 end if; 4607 end if; 4608 4609 -- Restore use clauses. For a child unit, use clauses in the parents 4610 -- are restored when installing the context, so only those in inner 4611 -- scopes (and those local to the child unit itself) need to be 4612 -- installed explicitly. 4613 4614 if Is_Child_Unit (Curr_Unit) and then Removed then 4615 for J in reverse 1 .. Num_Inner + 1 loop 4616 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4617 Use_Clauses (J); 4618 Install_Use_Clauses (Use_Clauses (J)); 4619 end loop; 4620 4621 else 4622 for J in reverse 1 .. Num_Scopes loop 4623 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4624 Use_Clauses (J); 4625 Install_Use_Clauses (Use_Clauses (J)); 4626 end loop; 4627 end if; 4628 4629 -- Restore status of instances. If one of them is a body, make its 4630 -- local entities visible again. 4631 4632 declare 4633 E : Entity_Id; 4634 Inst : Entity_Id; 4635 4636 begin 4637 for J in 1 .. N_Instances loop 4638 Inst := Instances (J); 4639 Set_Is_Generic_Instance (Inst, True); 4640 4641 if In_Package_Body (Inst) 4642 or else Ekind_In (S, E_Procedure, E_Function) 4643 then 4644 E := First_Entity (Instances (J)); 4645 while Present (E) loop 4646 Set_Is_Immediately_Visible (E); 4647 Next_Entity (E); 4648 end loop; 4649 end if; 4650 end loop; 4651 end; 4652 4653 -- If generic unit is in current unit, current context is correct. Note 4654 -- that the context is guaranteed to carry the correct SPARK_Mode as no 4655 -- enclosing scopes were removed. 4656 4657 else 4658 Instantiate_Package_Body 4659 (Body_Info => 4660 ((Inst_Node => N, 4661 Act_Decl => Act_Decl, 4662 Expander_Status => Expander_Active, 4663 Current_Sem_Unit => Current_Sem_Unit, 4664 Scope_Suppress => Scope_Suppress, 4665 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4666 Version => Ada_Version, 4667 Version_Pragma => Ada_Version_Pragma, 4668 Warnings => Save_Warnings, 4669 SPARK_Mode => SPARK_Mode, 4670 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 4671 Inlined_Body => True); 4672 end if; 4673 end Inline_Instance_Body; 4674 4675 ------------------------------------- 4676 -- Analyze_Procedure_Instantiation -- 4677 ------------------------------------- 4678 4679 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 4680 begin 4681 Analyze_Subprogram_Instantiation (N, E_Procedure); 4682 end Analyze_Procedure_Instantiation; 4683 4684 ----------------------------------- 4685 -- Need_Subprogram_Instance_Body -- 4686 ----------------------------------- 4687 4688 function Need_Subprogram_Instance_Body 4689 (N : Node_Id; 4690 Subp : Entity_Id) return Boolean 4691 is 4692 4693 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean; 4694 -- Return True if E is an inlined subprogram, an inlined renaming or a 4695 -- subprogram nested in an inlined subprogram. The inlining machinery 4696 -- totally disregards nested subprograms since it considers that they 4697 -- will always be compiled if the parent is (see Inline.Is_Nested). 4698 4699 ------------------------------------ 4700 -- Is_Inlined_Or_Child_Of_Inlined -- 4701 ------------------------------------ 4702 4703 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is 4704 Scop : Entity_Id; 4705 4706 begin 4707 if Is_Inlined (E) or else Is_Inlined (Alias (E)) then 4708 return True; 4709 end if; 4710 4711 Scop := Scope (E); 4712 while Scop /= Standard_Standard loop 4713 if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then 4714 return True; 4715 end if; 4716 4717 Scop := Scope (Scop); 4718 end loop; 4719 4720 return False; 4721 end Is_Inlined_Or_Child_Of_Inlined; 4722 4723 begin 4724 -- Must be in the main unit or inlined (or child of inlined) 4725 4726 if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) 4727 4728 -- Must be generating code or analyzing code in ASIS/GNATprove mode 4729 4730 and then (Operating_Mode = Generate_Code 4731 or else (Operating_Mode = Check_Semantics 4732 and then (ASIS_Mode or GNATprove_Mode))) 4733 4734 -- The body is needed when generating code (full expansion), in ASIS 4735 -- mode for other tools, and in GNATprove mode (special expansion) for 4736 -- formal verification of the body itself. 4737 4738 and then (Expander_Active or ASIS_Mode or GNATprove_Mode) 4739 4740 -- No point in inlining if ABE is inevitable 4741 4742 and then not ABE_Is_Certain (N) 4743 4744 -- Or if subprogram is eliminated 4745 4746 and then not Is_Eliminated (Subp) 4747 then 4748 Pending_Instantiations.Append 4749 ((Inst_Node => N, 4750 Act_Decl => Unit_Declaration_Node (Subp), 4751 Expander_Status => Expander_Active, 4752 Current_Sem_Unit => Current_Sem_Unit, 4753 Scope_Suppress => Scope_Suppress, 4754 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4755 Version => Ada_Version, 4756 Version_Pragma => Ada_Version_Pragma, 4757 Warnings => Save_Warnings, 4758 SPARK_Mode => SPARK_Mode, 4759 SPARK_Mode_Pragma => SPARK_Mode_Pragma)); 4760 return True; 4761 4762 -- Here if not inlined, or we ignore the inlining 4763 4764 else 4765 return False; 4766 end if; 4767 end Need_Subprogram_Instance_Body; 4768 4769 -------------------------------------- 4770 -- Analyze_Subprogram_Instantiation -- 4771 -------------------------------------- 4772 4773 procedure Analyze_Subprogram_Instantiation 4774 (N : Node_Id; 4775 K : Entity_Kind) 4776 is 4777 Loc : constant Source_Ptr := Sloc (N); 4778 Gen_Id : constant Node_Id := Name (N); 4779 4780 Anon_Id : constant Entity_Id := 4781 Make_Defining_Identifier (Sloc (Defining_Entity (N)), 4782 Chars => New_External_Name 4783 (Chars (Defining_Entity (N)), 'R')); 4784 4785 Act_Decl_Id : Entity_Id; 4786 Act_Decl : Node_Id; 4787 Act_Spec : Node_Id; 4788 Act_Tree : Node_Id; 4789 4790 Env_Installed : Boolean := False; 4791 Gen_Unit : Entity_Id; 4792 Gen_Decl : Node_Id; 4793 Pack_Id : Entity_Id; 4794 Parent_Installed : Boolean := False; 4795 4796 Renaming_List : List_Id; 4797 -- The list of declarations that link formals and actuals of the 4798 -- instance. These are subtype declarations for formal types, and 4799 -- renaming declarations for other formals. The subprogram declaration 4800 -- for the instance is then appended to the list, and the last item on 4801 -- the list is the renaming declaration for the instance. 4802 4803 procedure Analyze_Instance_And_Renamings; 4804 -- The instance must be analyzed in a context that includes the mappings 4805 -- of generic parameters into actuals. We create a package declaration 4806 -- for this purpose, and a subprogram with an internal name within the 4807 -- package. The subprogram instance is simply an alias for the internal 4808 -- subprogram, declared in the current scope. 4809 4810 procedure Build_Subprogram_Renaming; 4811 -- If the subprogram is recursive, there are occurrences of the name of 4812 -- the generic within the body, which must resolve to the current 4813 -- instance. We add a renaming declaration after the declaration, which 4814 -- is available in the instance body, as well as in the analysis of 4815 -- aspects that appear in the generic. This renaming declaration is 4816 -- inserted after the instance declaration which it renames. 4817 4818 ------------------------------------ 4819 -- Analyze_Instance_And_Renamings -- 4820 ------------------------------------ 4821 4822 procedure Analyze_Instance_And_Renamings is 4823 Def_Ent : constant Entity_Id := Defining_Entity (N); 4824 Pack_Decl : Node_Id; 4825 4826 begin 4827 if Nkind (Parent (N)) = N_Compilation_Unit then 4828 4829 -- For the case of a compilation unit, the container package has 4830 -- the same name as the instantiation, to insure that the binder 4831 -- calls the elaboration procedure with the right name. Copy the 4832 -- entity of the instance, which may have compilation level flags 4833 -- (e.g. Is_Child_Unit) set. 4834 4835 Pack_Id := New_Copy (Def_Ent); 4836 4837 else 4838 -- Otherwise we use the name of the instantiation concatenated 4839 -- with its source position to ensure uniqueness if there are 4840 -- several instantiations with the same name. 4841 4842 Pack_Id := 4843 Make_Defining_Identifier (Loc, 4844 Chars => New_External_Name 4845 (Related_Id => Chars (Def_Ent), 4846 Suffix => "GP", 4847 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 4848 end if; 4849 4850 Pack_Decl := 4851 Make_Package_Declaration (Loc, 4852 Specification => Make_Package_Specification (Loc, 4853 Defining_Unit_Name => Pack_Id, 4854 Visible_Declarations => Renaming_List, 4855 End_Label => Empty)); 4856 4857 Set_Instance_Spec (N, Pack_Decl); 4858 Set_Is_Generic_Instance (Pack_Id); 4859 Set_Debug_Info_Needed (Pack_Id); 4860 4861 -- Case of not a compilation unit 4862 4863 if Nkind (Parent (N)) /= N_Compilation_Unit then 4864 Mark_Rewrite_Insertion (Pack_Decl); 4865 Insert_Before (N, Pack_Decl); 4866 Set_Has_Completion (Pack_Id); 4867 4868 -- Case of an instantiation that is a compilation unit 4869 4870 -- Place declaration on current node so context is complete for 4871 -- analysis (including nested instantiations), and for use in a 4872 -- context_clause (see Analyze_With_Clause). 4873 4874 else 4875 Set_Unit (Parent (N), Pack_Decl); 4876 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 4877 end if; 4878 4879 Analyze (Pack_Decl); 4880 Check_Formal_Packages (Pack_Id); 4881 Set_Is_Generic_Instance (Pack_Id, False); 4882 4883 -- Why do we clear Is_Generic_Instance??? We set it 20 lines 4884 -- above??? 4885 4886 -- Body of the enclosing package is supplied when instantiating the 4887 -- subprogram body, after semantic analysis is completed. 4888 4889 if Nkind (Parent (N)) = N_Compilation_Unit then 4890 4891 -- Remove package itself from visibility, so it does not 4892 -- conflict with subprogram. 4893 4894 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 4895 4896 -- Set name and scope of internal subprogram so that the proper 4897 -- external name will be generated. The proper scope is the scope 4898 -- of the wrapper package. We need to generate debugging info for 4899 -- the internal subprogram, so set flag accordingly. 4900 4901 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 4902 Set_Scope (Anon_Id, Scope (Pack_Id)); 4903 4904 -- Mark wrapper package as referenced, to avoid spurious warnings 4905 -- if the instantiation appears in various with_ clauses of 4906 -- subunits of the main unit. 4907 4908 Set_Referenced (Pack_Id); 4909 end if; 4910 4911 Set_Is_Generic_Instance (Anon_Id); 4912 Set_Debug_Info_Needed (Anon_Id); 4913 Act_Decl_Id := New_Copy (Anon_Id); 4914 4915 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4916 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 4917 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 4918 4919 -- Subprogram instance comes from source only if generic does 4920 4921 Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit)); 4922 4923 -- The signature may involve types that are not frozen yet, but the 4924 -- subprogram will be frozen at the point the wrapper package is 4925 -- frozen, so it does not need its own freeze node. In fact, if one 4926 -- is created, it might conflict with the freezing actions from the 4927 -- wrapper package. 4928 4929 Set_Has_Delayed_Freeze (Anon_Id, False); 4930 4931 -- If the instance is a child unit, mark the Id accordingly. Mark 4932 -- the anonymous entity as well, which is the real subprogram and 4933 -- which is used when the instance appears in a context clause. 4934 -- Similarly, propagate the Is_Eliminated flag to handle properly 4935 -- nested eliminated subprograms. 4936 4937 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 4938 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 4939 New_Overloaded_Entity (Act_Decl_Id); 4940 Check_Eliminated (Act_Decl_Id); 4941 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 4942 4943 -- In compilation unit case, kill elaboration checks on the 4944 -- instantiation, since they are never needed -- the body is 4945 -- instantiated at the same point as the spec. 4946 4947 if Nkind (Parent (N)) = N_Compilation_Unit then 4948 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4949 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4950 Set_Is_Compilation_Unit (Anon_Id); 4951 4952 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 4953 end if; 4954 4955 -- The instance is not a freezing point for the new subprogram 4956 4957 Set_Is_Frozen (Act_Decl_Id, False); 4958 4959 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 4960 Valid_Operator_Definition (Act_Decl_Id); 4961 end if; 4962 4963 Set_Alias (Act_Decl_Id, Anon_Id); 4964 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4965 Set_Has_Completion (Act_Decl_Id); 4966 Set_Related_Instance (Pack_Id, Act_Decl_Id); 4967 4968 if Nkind (Parent (N)) = N_Compilation_Unit then 4969 Set_Body_Required (Parent (N), False); 4970 end if; 4971 end Analyze_Instance_And_Renamings; 4972 4973 ------------------------------- 4974 -- Build_Subprogram_Renaming -- 4975 ------------------------------- 4976 4977 procedure Build_Subprogram_Renaming is 4978 Renaming_Decl : Node_Id; 4979 Unit_Renaming : Node_Id; 4980 4981 begin 4982 Unit_Renaming := 4983 Make_Subprogram_Renaming_Declaration (Loc, 4984 Specification => 4985 Copy_Generic_Node 4986 (Specification (Original_Node (Gen_Decl)), 4987 Empty, 4988 Instantiating => True), 4989 Name => New_Occurrence_Of (Anon_Id, Loc)); 4990 4991 -- The generic may be a a child unit. The renaming needs an 4992 -- identifier with the proper name. 4993 4994 Set_Defining_Unit_Name (Specification (Unit_Renaming), 4995 Make_Defining_Identifier (Loc, Chars (Gen_Unit))); 4996 4997 -- If there is a formal subprogram with the same name as the unit 4998 -- itself, do not add this renaming declaration, to prevent 4999 -- ambiguities when there is a call with that name in the body. 5000 -- This is a partial and ugly fix for one ACATS test. ??? 5001 5002 Renaming_Decl := First (Renaming_List); 5003 while Present (Renaming_Decl) loop 5004 if Nkind (Renaming_Decl) = N_Subprogram_Renaming_Declaration 5005 and then 5006 Chars (Defining_Entity (Renaming_Decl)) = Chars (Gen_Unit) 5007 then 5008 exit; 5009 end if; 5010 5011 Next (Renaming_Decl); 5012 end loop; 5013 5014 if No (Renaming_Decl) then 5015 Append (Unit_Renaming, Renaming_List); 5016 end if; 5017 end Build_Subprogram_Renaming; 5018 5019 -- Local variables 5020 5021 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; 5022 -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit 5023 5024 Save_SM : constant SPARK_Mode_Type := SPARK_Mode; 5025 Save_SMP : constant Node_Id := SPARK_Mode_Pragma; 5026 -- Save the SPARK_Mode-related data for restore on exit 5027 5028 Vis_Prims_List : Elist_Id := No_Elist; 5029 -- List of primitives made temporarily visible in the instantiation 5030 -- to match the visibility of the formal type 5031 5032 -- Start of processing for Analyze_Subprogram_Instantiation 5033 5034 begin 5035 Check_SPARK_05_Restriction ("generic is not allowed", N); 5036 5037 -- Very first thing: check for special Text_IO unit in case we are 5038 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course 5039 -- such an instantiation is bogus (these are packages, not subprograms), 5040 -- but we get a better error message if we do this. 5041 5042 Check_Text_IO_Special_Unit (Gen_Id); 5043 5044 -- Make node global for error reporting 5045 5046 Instantiation_Node := N; 5047 5048 -- For package instantiations we turn off style checks, because they 5049 -- will have been emitted in the generic. For subprogram instantiations 5050 -- we want to apply at least the check on overriding indicators so we 5051 -- do not modify the style check status. 5052 5053 -- The renaming declarations for the actuals do not come from source and 5054 -- will not generate spurious warnings. 5055 5056 Preanalyze_Actuals (N); 5057 5058 Init_Env; 5059 Env_Installed := True; 5060 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 5061 Gen_Unit := Entity (Gen_Id); 5062 5063 Generate_Reference (Gen_Unit, Gen_Id); 5064 5065 if Nkind (Gen_Id) = N_Identifier 5066 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 5067 then 5068 Error_Msg_NE 5069 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 5070 end if; 5071 5072 if Etype (Gen_Unit) = Any_Type then 5073 Restore_Env; 5074 return; 5075 end if; 5076 5077 -- Verify that it is a generic subprogram of the right kind, and that 5078 -- it does not lead to a circular instantiation. 5079 5080 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then 5081 Error_Msg_NE 5082 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); 5083 5084 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then 5085 Error_Msg_NE 5086 ("& is not the name of a generic function", Gen_Id, Gen_Unit); 5087 5088 elsif In_Open_Scopes (Gen_Unit) then 5089 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 5090 5091 else 5092 -- If the context of the instance is subject to SPARK_Mode "off" or 5093 -- the annotation is altogether missing, set the global flag which 5094 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 5095 -- the instance. 5096 5097 if SPARK_Mode /= On then 5098 Ignore_Pragma_SPARK_Mode := True; 5099 end if; 5100 5101 Set_Entity (Gen_Id, Gen_Unit); 5102 Set_Is_Instantiated (Gen_Unit); 5103 5104 if In_Extended_Main_Source_Unit (N) then 5105 Generate_Reference (Gen_Unit, N); 5106 end if; 5107 5108 -- If renaming, get original unit 5109 5110 if Present (Renamed_Object (Gen_Unit)) 5111 and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, 5112 E_Generic_Function) 5113 then 5114 Gen_Unit := Renamed_Object (Gen_Unit); 5115 Set_Is_Instantiated (Gen_Unit); 5116 Generate_Reference (Gen_Unit, N); 5117 end if; 5118 5119 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 5120 Error_Msg_Node_2 := Current_Scope; 5121 Error_Msg_NE 5122 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 5123 Circularity_Detected := True; 5124 Restore_Hidden_Primitives (Vis_Prims_List); 5125 goto Leave; 5126 end if; 5127 5128 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 5129 5130 -- Initialize renamings map, for error checking 5131 5132 Generic_Renamings.Set_Last (0); 5133 Generic_Renamings_HTable.Reset; 5134 5135 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 5136 5137 -- Copy original generic tree, to produce text for instantiation 5138 5139 Act_Tree := 5140 Copy_Generic_Node 5141 (Original_Node (Gen_Decl), Empty, Instantiating => True); 5142 5143 -- Inherit overriding indicator from instance node 5144 5145 Act_Spec := Specification (Act_Tree); 5146 Set_Must_Override (Act_Spec, Must_Override (N)); 5147 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 5148 5149 Renaming_List := 5150 Analyze_Associations 5151 (I_Node => N, 5152 Formals => Generic_Formal_Declarations (Act_Tree), 5153 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 5154 5155 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 5156 5157 -- The subprogram itself cannot contain a nested instance, so the 5158 -- current parent is left empty. 5159 5160 Set_Instance_Env (Gen_Unit, Empty); 5161 5162 -- Build the subprogram declaration, which does not appear in the 5163 -- generic template, and give it a sloc consistent with that of the 5164 -- template. 5165 5166 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 5167 Set_Generic_Parent (Act_Spec, Gen_Unit); 5168 Act_Decl := 5169 Make_Subprogram_Declaration (Sloc (Act_Spec), 5170 Specification => Act_Spec); 5171 5172 -- The aspects have been copied previously, but they have to be 5173 -- linked explicitly to the new subprogram declaration. Explicit 5174 -- pre/postconditions on the instance are analyzed below, in a 5175 -- separate step. 5176 5177 Move_Aspects (Act_Tree, To => Act_Decl); 5178 Set_Categorization_From_Pragmas (Act_Decl); 5179 5180 if Parent_Installed then 5181 Hide_Current_Scope; 5182 end if; 5183 5184 Append (Act_Decl, Renaming_List); 5185 5186 -- Contract-related source pragmas that follow a generic subprogram 5187 -- must be instantiated explicitly because they are not part of the 5188 -- subprogram template. 5189 5190 Instantiate_Subprogram_Contract 5191 (Original_Node (Gen_Decl), Renaming_List); 5192 5193 Build_Subprogram_Renaming; 5194 Analyze_Instance_And_Renamings; 5195 5196 -- If the generic is marked Import (Intrinsic), then so is the 5197 -- instance. This indicates that there is no body to instantiate. If 5198 -- generic is marked inline, so it the instance, and the anonymous 5199 -- subprogram it renames. If inlined, or else if inlining is enabled 5200 -- for the compilation, we generate the instance body even if it is 5201 -- not within the main unit. 5202 5203 if Is_Intrinsic_Subprogram (Gen_Unit) then 5204 Set_Is_Intrinsic_Subprogram (Anon_Id); 5205 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 5206 5207 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 5208 Validate_Unchecked_Conversion (N, Act_Decl_Id); 5209 end if; 5210 end if; 5211 5212 -- Inherit convention from generic unit. Intrinsic convention, as for 5213 -- an instance of unchecked conversion, is not inherited because an 5214 -- explicit Ada instance has been created. 5215 5216 if Has_Convention_Pragma (Gen_Unit) 5217 and then Convention (Gen_Unit) /= Convention_Intrinsic 5218 then 5219 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 5220 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 5221 end if; 5222 5223 Generate_Definition (Act_Decl_Id); 5224 5225 -- Inherit all inlining-related flags which apply to the generic in 5226 -- the subprogram and its declaration. 5227 5228 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 5229 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 5230 5231 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 5232 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 5233 5234 Set_Has_Pragma_Inline_Always 5235 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5236 Set_Has_Pragma_Inline_Always 5237 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5238 5239 if not Is_Intrinsic_Subprogram (Gen_Unit) then 5240 Check_Elab_Instantiation (N); 5241 end if; 5242 5243 if Is_Dispatching_Operation (Act_Decl_Id) 5244 and then Ada_Version >= Ada_2005 5245 then 5246 declare 5247 Formal : Entity_Id; 5248 5249 begin 5250 Formal := First_Formal (Act_Decl_Id); 5251 while Present (Formal) loop 5252 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 5253 and then Is_Controlling_Formal (Formal) 5254 and then not Can_Never_Be_Null (Formal) 5255 then 5256 Error_Msg_NE 5257 ("access parameter& is controlling,", N, Formal); 5258 Error_Msg_NE 5259 ("\corresponding parameter of & must be " 5260 & "explicitly null-excluding", N, Gen_Id); 5261 end if; 5262 5263 Next_Formal (Formal); 5264 end loop; 5265 end; 5266 end if; 5267 5268 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 5269 5270 Validate_Categorization_Dependency (N, Act_Decl_Id); 5271 5272 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 5273 Inherit_Context (Gen_Decl, N); 5274 5275 Restore_Private_Views (Pack_Id, False); 5276 5277 -- If the context requires a full instantiation, mark node for 5278 -- subsequent construction of the body. 5279 5280 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 5281 Check_Forward_Instantiation (Gen_Decl); 5282 5283 -- The wrapper package is always delayed, because it does not 5284 -- constitute a freeze point, but to insure that the freeze node 5285 -- is placed properly, it is created directly when instantiating 5286 -- the body (otherwise the freeze node might appear to early for 5287 -- nested instantiations). For ASIS purposes, indicate that the 5288 -- wrapper package has replaced the instantiation node. 5289 5290 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5291 Rewrite (N, Unit (Parent (N))); 5292 Set_Unit (Parent (N), N); 5293 end if; 5294 5295 -- Replace instance node for library-level instantiations of 5296 -- intrinsic subprograms, for ASIS use. 5297 5298 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5299 Rewrite (N, Unit (Parent (N))); 5300 Set_Unit (Parent (N), N); 5301 end if; 5302 5303 if Parent_Installed then 5304 Remove_Parent; 5305 end if; 5306 5307 Restore_Hidden_Primitives (Vis_Prims_List); 5308 Restore_Env; 5309 Env_Installed := False; 5310 Generic_Renamings.Set_Last (0); 5311 Generic_Renamings_HTable.Reset; 5312 5313 Ignore_Pragma_SPARK_Mode := Save_IPSM; 5314 SPARK_Mode := Save_SM; 5315 SPARK_Mode_Pragma := Save_SMP; 5316 5317 if SPARK_Mode = On then 5318 Dynamic_Elaboration_Checks := False; 5319 end if; 5320 end if; 5321 5322 <<Leave>> 5323 if Has_Aspects (N) then 5324 Analyze_Aspect_Specifications (N, Act_Decl_Id); 5325 end if; 5326 5327 exception 5328 when Instantiation_Error => 5329 if Parent_Installed then 5330 Remove_Parent; 5331 end if; 5332 5333 if Env_Installed then 5334 Restore_Env; 5335 end if; 5336 5337 Ignore_Pragma_SPARK_Mode := Save_IPSM; 5338 SPARK_Mode := Save_SM; 5339 SPARK_Mode_Pragma := Save_SMP; 5340 5341 if SPARK_Mode = On then 5342 Dynamic_Elaboration_Checks := False; 5343 end if; 5344 end Analyze_Subprogram_Instantiation; 5345 5346 ------------------------- 5347 -- Get_Associated_Node -- 5348 ------------------------- 5349 5350 function Get_Associated_Node (N : Node_Id) return Node_Id is 5351 Assoc : Node_Id; 5352 5353 begin 5354 Assoc := Associated_Node (N); 5355 5356 if Nkind (Assoc) /= Nkind (N) then 5357 return Assoc; 5358 5359 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 5360 return Assoc; 5361 5362 else 5363 -- If the node is part of an inner generic, it may itself have been 5364 -- remapped into a further generic copy. Associated_Node is otherwise 5365 -- used for the entity of the node, and will be of a different node 5366 -- kind, or else N has been rewritten as a literal or function call. 5367 5368 while Present (Associated_Node (Assoc)) 5369 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 5370 loop 5371 Assoc := Associated_Node (Assoc); 5372 end loop; 5373 5374 -- Follow and additional link in case the final node was rewritten. 5375 -- This can only happen with nested generic units. 5376 5377 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 5378 and then Present (Associated_Node (Assoc)) 5379 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 5380 N_Explicit_Dereference, 5381 N_Integer_Literal, 5382 N_Real_Literal, 5383 N_String_Literal)) 5384 then 5385 Assoc := Associated_Node (Assoc); 5386 end if; 5387 5388 -- An additional special case: an unconstrained type in an object 5389 -- declaration may have been rewritten as a local subtype constrained 5390 -- by the expression in the declaration. We need to recover the 5391 -- original entity which may be global. 5392 5393 if Present (Original_Node (Assoc)) 5394 and then Nkind (Parent (N)) = N_Object_Declaration 5395 then 5396 Assoc := Original_Node (Assoc); 5397 end if; 5398 5399 return Assoc; 5400 end if; 5401 end Get_Associated_Node; 5402 5403 ---------------------------- 5404 -- Build_Function_Wrapper -- 5405 ---------------------------- 5406 5407 function Build_Function_Wrapper 5408 (Formal_Subp : Entity_Id; 5409 Actual_Subp : Entity_Id) return Node_Id 5410 is 5411 Loc : constant Source_Ptr := Sloc (Current_Scope); 5412 Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); 5413 Actuals : List_Id; 5414 Decl : Node_Id; 5415 Func_Name : Node_Id; 5416 Func : Entity_Id; 5417 Parm_Type : Node_Id; 5418 Profile : List_Id := New_List; 5419 Spec : Node_Id; 5420 Act_F : Entity_Id; 5421 Form_F : Entity_Id; 5422 New_F : Entity_Id; 5423 5424 begin 5425 Func_Name := New_Occurrence_Of (Actual_Subp, Loc); 5426 5427 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5428 Set_Ekind (Func, E_Function); 5429 Set_Is_Generic_Actual_Subprogram (Func); 5430 5431 Actuals := New_List; 5432 Profile := New_List; 5433 5434 Act_F := First_Formal (Actual_Subp); 5435 Form_F := First_Formal (Formal_Subp); 5436 while Present (Form_F) loop 5437 5438 -- Create new formal for profile of wrapper, and add a reference 5439 -- to it in the list of actuals for the enclosing call. The name 5440 -- must be that of the formal in the formal subprogram, because 5441 -- calls to it in the generic body may use named associations. 5442 5443 New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); 5444 5445 Parm_Type := 5446 New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc); 5447 5448 Append_To (Profile, 5449 Make_Parameter_Specification (Loc, 5450 Defining_Identifier => New_F, 5451 Parameter_Type => Parm_Type)); 5452 5453 Append_To (Actuals, New_Occurrence_Of (New_F, Loc)); 5454 Next_Formal (Form_F); 5455 5456 if Present (Act_F) then 5457 Next_Formal (Act_F); 5458 end if; 5459 end loop; 5460 5461 Spec := 5462 Make_Function_Specification (Loc, 5463 Defining_Unit_Name => Func, 5464 Parameter_Specifications => Profile, 5465 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5466 5467 Decl := 5468 Make_Expression_Function (Loc, 5469 Specification => Spec, 5470 Expression => 5471 Make_Function_Call (Loc, 5472 Name => Func_Name, 5473 Parameter_Associations => Actuals)); 5474 5475 return Decl; 5476 end Build_Function_Wrapper; 5477 5478 ---------------------------- 5479 -- Build_Operator_Wrapper -- 5480 ---------------------------- 5481 5482 function Build_Operator_Wrapper 5483 (Formal_Subp : Entity_Id; 5484 Actual_Subp : Entity_Id) return Node_Id 5485 is 5486 Loc : constant Source_Ptr := Sloc (Current_Scope); 5487 Ret_Type : constant Entity_Id := 5488 Get_Instance_Of (Etype (Formal_Subp)); 5489 Op_Type : constant Entity_Id := 5490 Get_Instance_Of (Etype (First_Formal (Formal_Subp))); 5491 Is_Binary : constant Boolean := 5492 Present (Next_Formal (First_Formal (Formal_Subp))); 5493 5494 Decl : Node_Id; 5495 Expr : Node_Id; 5496 F1, F2 : Entity_Id; 5497 Func : Entity_Id; 5498 Op_Name : Name_Id; 5499 Spec : Node_Id; 5500 L, R : Node_Id; 5501 5502 begin 5503 Op_Name := Chars (Actual_Subp); 5504 5505 -- Create entities for wrapper function and its formals 5506 5507 F1 := Make_Temporary (Loc, 'A'); 5508 F2 := Make_Temporary (Loc, 'B'); 5509 L := New_Occurrence_Of (F1, Loc); 5510 R := New_Occurrence_Of (F2, Loc); 5511 5512 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5513 Set_Ekind (Func, E_Function); 5514 Set_Is_Generic_Actual_Subprogram (Func); 5515 5516 Spec := 5517 Make_Function_Specification (Loc, 5518 Defining_Unit_Name => Func, 5519 Parameter_Specifications => New_List ( 5520 Make_Parameter_Specification (Loc, 5521 Defining_Identifier => F1, 5522 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))), 5523 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5524 5525 if Is_Binary then 5526 Append_To (Parameter_Specifications (Spec), 5527 Make_Parameter_Specification (Loc, 5528 Defining_Identifier => F2, 5529 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))); 5530 end if; 5531 5532 -- Build expression as a function call, or as an operator node 5533 -- that corresponds to the name of the actual, starting with 5534 -- binary operators. 5535 5536 if Op_Name not in Any_Operator_Name then 5537 Expr := 5538 Make_Function_Call (Loc, 5539 Name => 5540 New_Occurrence_Of (Actual_Subp, Loc), 5541 Parameter_Associations => New_List (L)); 5542 5543 if Is_Binary then 5544 Append_To (Parameter_Associations (Expr), R); 5545 end if; 5546 5547 -- Binary operators 5548 5549 elsif Is_Binary then 5550 if Op_Name = Name_Op_And then 5551 Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R); 5552 elsif Op_Name = Name_Op_Or then 5553 Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R); 5554 elsif Op_Name = Name_Op_Xor then 5555 Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R); 5556 elsif Op_Name = Name_Op_Eq then 5557 Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); 5558 elsif Op_Name = Name_Op_Ne then 5559 Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); 5560 elsif Op_Name = Name_Op_Le then 5561 Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R); 5562 elsif Op_Name = Name_Op_Gt then 5563 Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R); 5564 elsif Op_Name = Name_Op_Ge then 5565 Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R); 5566 elsif Op_Name = Name_Op_Lt then 5567 Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R); 5568 elsif Op_Name = Name_Op_Add then 5569 Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R); 5570 elsif Op_Name = Name_Op_Subtract then 5571 Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R); 5572 elsif Op_Name = Name_Op_Concat then 5573 Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R); 5574 elsif Op_Name = Name_Op_Multiply then 5575 Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R); 5576 elsif Op_Name = Name_Op_Divide then 5577 Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R); 5578 elsif Op_Name = Name_Op_Mod then 5579 Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R); 5580 elsif Op_Name = Name_Op_Rem then 5581 Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R); 5582 elsif Op_Name = Name_Op_Expon then 5583 Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R); 5584 end if; 5585 5586 -- Unary operators 5587 5588 else 5589 if Op_Name = Name_Op_Add then 5590 Expr := Make_Op_Plus (Loc, Right_Opnd => L); 5591 elsif Op_Name = Name_Op_Subtract then 5592 Expr := Make_Op_Minus (Loc, Right_Opnd => L); 5593 elsif Op_Name = Name_Op_Abs then 5594 Expr := Make_Op_Abs (Loc, Right_Opnd => L); 5595 elsif Op_Name = Name_Op_Not then 5596 Expr := Make_Op_Not (Loc, Right_Opnd => L); 5597 end if; 5598 end if; 5599 5600 Decl := 5601 Make_Expression_Function (Loc, 5602 Specification => Spec, 5603 Expression => Expr); 5604 5605 return Decl; 5606 end Build_Operator_Wrapper; 5607 5608 ------------------------------------------- 5609 -- Build_Instance_Compilation_Unit_Nodes -- 5610 ------------------------------------------- 5611 5612 procedure Build_Instance_Compilation_Unit_Nodes 5613 (N : Node_Id; 5614 Act_Body : Node_Id; 5615 Act_Decl : Node_Id) 5616 is 5617 Decl_Cunit : Node_Id; 5618 Body_Cunit : Node_Id; 5619 Citem : Node_Id; 5620 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 5621 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 5622 5623 begin 5624 -- A new compilation unit node is built for the instance declaration 5625 5626 Decl_Cunit := 5627 Make_Compilation_Unit (Sloc (N), 5628 Context_Items => Empty_List, 5629 Unit => Act_Decl, 5630 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); 5631 5632 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 5633 5634 -- The new compilation unit is linked to its body, but both share the 5635 -- same file, so we do not set Body_Required on the new unit so as not 5636 -- to create a spurious dependency on a non-existent body in the ali. 5637 -- This simplifies CodePeer unit traversal. 5638 5639 -- We use the original instantiation compilation unit as the resulting 5640 -- compilation unit of the instance, since this is the main unit. 5641 5642 Rewrite (N, Act_Body); 5643 5644 -- Propagate the aspect specifications from the package body template to 5645 -- the instantiated version of the package body. 5646 5647 if Has_Aspects (Act_Body) then 5648 Set_Aspect_Specifications 5649 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body))); 5650 end if; 5651 5652 Body_Cunit := Parent (N); 5653 5654 -- The two compilation unit nodes are linked by the Library_Unit field 5655 5656 Set_Library_Unit (Decl_Cunit, Body_Cunit); 5657 Set_Library_Unit (Body_Cunit, Decl_Cunit); 5658 5659 -- Preserve the private nature of the package if needed 5660 5661 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 5662 5663 -- If the instance is not the main unit, its context, categorization 5664 -- and elaboration entity are not relevant to the compilation. 5665 5666 if Body_Cunit /= Cunit (Main_Unit) then 5667 Make_Instance_Unit (Body_Cunit, In_Main => False); 5668 return; 5669 end if; 5670 5671 -- The context clause items on the instantiation, which are now attached 5672 -- to the body compilation unit (since the body overwrote the original 5673 -- instantiation node), semantically belong on the spec, so copy them 5674 -- there. It's harmless to leave them on the body as well. In fact one 5675 -- could argue that they belong in both places. 5676 5677 Citem := First (Context_Items (Body_Cunit)); 5678 while Present (Citem) loop 5679 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 5680 Next (Citem); 5681 end loop; 5682 5683 -- Propagate categorization flags on packages, so that they appear in 5684 -- the ali file for the spec of the unit. 5685 5686 if Ekind (New_Main) = E_Package then 5687 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 5688 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 5689 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 5690 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 5691 Set_Is_Remote_Call_Interface 5692 (Old_Main, Is_Remote_Call_Interface (New_Main)); 5693 end if; 5694 5695 -- Make entry in Units table, so that binder can generate call to 5696 -- elaboration procedure for body, if any. 5697 5698 Make_Instance_Unit (Body_Cunit, In_Main => True); 5699 Main_Unit_Entity := New_Main; 5700 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 5701 5702 -- Build elaboration entity, since the instance may certainly generate 5703 -- elaboration code requiring a flag for protection. 5704 5705 Build_Elaboration_Entity (Decl_Cunit, New_Main); 5706 end Build_Instance_Compilation_Unit_Nodes; 5707 5708 ----------------------------- 5709 -- Check_Access_Definition -- 5710 ----------------------------- 5711 5712 procedure Check_Access_Definition (N : Node_Id) is 5713 begin 5714 pragma Assert 5715 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); 5716 null; 5717 end Check_Access_Definition; 5718 5719 ----------------------------------- 5720 -- Check_Formal_Package_Instance -- 5721 ----------------------------------- 5722 5723 -- If the formal has specific parameters, they must match those of the 5724 -- actual. Both of them are instances, and the renaming declarations for 5725 -- their formal parameters appear in the same order in both. The analyzed 5726 -- formal has been analyzed in the context of the current instance. 5727 5728 procedure Check_Formal_Package_Instance 5729 (Formal_Pack : Entity_Id; 5730 Actual_Pack : Entity_Id) 5731 is 5732 E1 : Entity_Id := First_Entity (Actual_Pack); 5733 E2 : Entity_Id := First_Entity (Formal_Pack); 5734 5735 Expr1 : Node_Id; 5736 Expr2 : Node_Id; 5737 5738 procedure Check_Mismatch (B : Boolean); 5739 -- Common error routine for mismatch between the parameters of the 5740 -- actual instance and those of the formal package. 5741 5742 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 5743 -- The formal may come from a nested formal package, and the actual may 5744 -- have been constant-folded. To determine whether the two denote the 5745 -- same entity we may have to traverse several definitions to recover 5746 -- the ultimate entity that they refer to. 5747 5748 function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean; 5749 -- The formal and the actual must be identical, but if both are 5750 -- given by attributes they end up renaming different generated bodies, 5751 -- and we must verify that the attributes themselves match. 5752 5753 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 5754 -- Similarly, if the formal comes from a nested formal package, the 5755 -- actual may designate the formal through multiple renamings, which 5756 -- have to be followed to determine the original variable in question. 5757 5758 -------------------- 5759 -- Check_Mismatch -- 5760 -------------------- 5761 5762 procedure Check_Mismatch (B : Boolean) is 5763 Kind : constant Node_Kind := Nkind (Parent (E2)); 5764 5765 begin 5766 if Kind = N_Formal_Type_Declaration then 5767 return; 5768 5769 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 5770 N_Formal_Package_Declaration) 5771 or else Kind in N_Formal_Subprogram_Declaration 5772 then 5773 null; 5774 5775 -- Ada 2012: If both formal and actual are incomplete types they 5776 -- are conformant. 5777 5778 elsif Is_Incomplete_Type (E1) and then Is_Incomplete_Type (E2) then 5779 null; 5780 5781 elsif B then 5782 Error_Msg_NE 5783 ("actual for & in actual instance does not match formal", 5784 Parent (Actual_Pack), E1); 5785 end if; 5786 end Check_Mismatch; 5787 5788 -------------------------------- 5789 -- Same_Instantiated_Constant -- 5790 -------------------------------- 5791 5792 function Same_Instantiated_Constant 5793 (E1, E2 : Entity_Id) return Boolean 5794 is 5795 Ent : Entity_Id; 5796 5797 begin 5798 Ent := E2; 5799 while Present (Ent) loop 5800 if E1 = Ent then 5801 return True; 5802 5803 elsif Ekind (Ent) /= E_Constant then 5804 return False; 5805 5806 elsif Is_Entity_Name (Constant_Value (Ent)) then 5807 if Entity (Constant_Value (Ent)) = E1 then 5808 return True; 5809 else 5810 Ent := Entity (Constant_Value (Ent)); 5811 end if; 5812 5813 -- The actual may be a constant that has been folded. Recover 5814 -- original name. 5815 5816 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 5817 Ent := Entity (Original_Node (Constant_Value (Ent))); 5818 5819 else 5820 return False; 5821 end if; 5822 end loop; 5823 5824 return False; 5825 end Same_Instantiated_Constant; 5826 5827 -------------------------------- 5828 -- Same_Instantiated_Function -- 5829 -------------------------------- 5830 5831 function Same_Instantiated_Function 5832 (E1, E2 : Entity_Id) return Boolean 5833 is 5834 U1, U2 : Node_Id; 5835 begin 5836 if Alias (E1) = Alias (E2) then 5837 return True; 5838 5839 elsif Present (Alias (E2)) then 5840 U1 := Original_Node (Unit_Declaration_Node (E1)); 5841 U2 := Original_Node (Unit_Declaration_Node (Alias (E2))); 5842 5843 return Nkind (U1) = N_Subprogram_Renaming_Declaration 5844 and then Nkind (Name (U1)) = N_Attribute_Reference 5845 5846 and then Nkind (U2) = N_Subprogram_Renaming_Declaration 5847 and then Nkind (Name (U2)) = N_Attribute_Reference 5848 5849 and then 5850 Attribute_Name (Name (U1)) = Attribute_Name (Name (U2)); 5851 else 5852 return False; 5853 end if; 5854 end Same_Instantiated_Function; 5855 5856 -------------------------------- 5857 -- Same_Instantiated_Variable -- 5858 -------------------------------- 5859 5860 function Same_Instantiated_Variable 5861 (E1, E2 : Entity_Id) return Boolean 5862 is 5863 function Original_Entity (E : Entity_Id) return Entity_Id; 5864 -- Follow chain of renamings to the ultimate ancestor 5865 5866 --------------------- 5867 -- Original_Entity -- 5868 --------------------- 5869 5870 function Original_Entity (E : Entity_Id) return Entity_Id is 5871 Orig : Entity_Id; 5872 5873 begin 5874 Orig := E; 5875 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 5876 and then Present (Renamed_Object (Orig)) 5877 and then Is_Entity_Name (Renamed_Object (Orig)) 5878 loop 5879 Orig := Entity (Renamed_Object (Orig)); 5880 end loop; 5881 5882 return Orig; 5883 end Original_Entity; 5884 5885 -- Start of processing for Same_Instantiated_Variable 5886 5887 begin 5888 return Ekind (E1) = Ekind (E2) 5889 and then Original_Entity (E1) = Original_Entity (E2); 5890 end Same_Instantiated_Variable; 5891 5892 -- Start of processing for Check_Formal_Package_Instance 5893 5894 begin 5895 while Present (E1) and then Present (E2) loop 5896 exit when Ekind (E1) = E_Package 5897 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 5898 5899 -- If the formal is the renaming of the formal package, this 5900 -- is the end of its formal part, which may occur before the 5901 -- end of the formal part in the actual in the presence of 5902 -- defaulted parameters in the formal package. 5903 5904 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 5905 and then Renamed_Entity (E2) = Scope (E2); 5906 5907 -- The analysis of the actual may generate additional internal 5908 -- entities. If the formal is defaulted, there is no corresponding 5909 -- analysis and the internal entities must be skipped, until we 5910 -- find corresponding entities again. 5911 5912 if Comes_From_Source (E2) 5913 and then not Comes_From_Source (E1) 5914 and then Chars (E1) /= Chars (E2) 5915 then 5916 while Present (E1) and then Chars (E1) /= Chars (E2) loop 5917 Next_Entity (E1); 5918 end loop; 5919 end if; 5920 5921 if No (E1) then 5922 return; 5923 5924 -- If the formal entity comes from a formal declaration, it was 5925 -- defaulted in the formal package, and no check is needed on it. 5926 5927 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then 5928 goto Next_E; 5929 5930 -- Ditto for defaulted formal subprograms. 5931 5932 elsif Is_Overloadable (E1) 5933 and then Nkind (Unit_Declaration_Node (E2)) in 5934 N_Formal_Subprogram_Declaration 5935 then 5936 goto Next_E; 5937 5938 elsif Is_Type (E1) then 5939 5940 -- Subtypes must statically match. E1, E2 are the local entities 5941 -- that are subtypes of the actuals. Itypes generated for other 5942 -- parameters need not be checked, the check will be performed 5943 -- on the parameters themselves. 5944 5945 -- If E2 is a formal type declaration, it is a defaulted parameter 5946 -- and needs no checking. 5947 5948 if not Is_Itype (E1) and then not Is_Itype (E2) then 5949 Check_Mismatch 5950 (not Is_Type (E2) 5951 or else Etype (E1) /= Etype (E2) 5952 or else not Subtypes_Statically_Match (E1, E2)); 5953 end if; 5954 5955 elsif Ekind (E1) = E_Constant then 5956 5957 -- IN parameters must denote the same static value, or the same 5958 -- constant, or the literal null. 5959 5960 Expr1 := Expression (Parent (E1)); 5961 5962 if Ekind (E2) /= E_Constant then 5963 Check_Mismatch (True); 5964 goto Next_E; 5965 else 5966 Expr2 := Expression (Parent (E2)); 5967 end if; 5968 5969 if Is_OK_Static_Expression (Expr1) then 5970 if not Is_OK_Static_Expression (Expr2) then 5971 Check_Mismatch (True); 5972 5973 elsif Is_Discrete_Type (Etype (E1)) then 5974 declare 5975 V1 : constant Uint := Expr_Value (Expr1); 5976 V2 : constant Uint := Expr_Value (Expr2); 5977 begin 5978 Check_Mismatch (V1 /= V2); 5979 end; 5980 5981 elsif Is_Real_Type (Etype (E1)) then 5982 declare 5983 V1 : constant Ureal := Expr_Value_R (Expr1); 5984 V2 : constant Ureal := Expr_Value_R (Expr2); 5985 begin 5986 Check_Mismatch (V1 /= V2); 5987 end; 5988 5989 elsif Is_String_Type (Etype (E1)) 5990 and then Nkind (Expr1) = N_String_Literal 5991 then 5992 if Nkind (Expr2) /= N_String_Literal then 5993 Check_Mismatch (True); 5994 else 5995 Check_Mismatch 5996 (not String_Equal (Strval (Expr1), Strval (Expr2))); 5997 end if; 5998 end if; 5999 6000 elsif Is_Entity_Name (Expr1) then 6001 if Is_Entity_Name (Expr2) then 6002 if Entity (Expr1) = Entity (Expr2) then 6003 null; 6004 else 6005 Check_Mismatch 6006 (not Same_Instantiated_Constant 6007 (Entity (Expr1), Entity (Expr2))); 6008 end if; 6009 6010 else 6011 Check_Mismatch (True); 6012 end if; 6013 6014 elsif Is_Entity_Name (Original_Node (Expr1)) 6015 and then Is_Entity_Name (Expr2) 6016 and then Same_Instantiated_Constant 6017 (Entity (Original_Node (Expr1)), Entity (Expr2)) 6018 then 6019 null; 6020 6021 elsif Nkind (Expr1) = N_Null then 6022 Check_Mismatch (Nkind (Expr1) /= N_Null); 6023 6024 else 6025 Check_Mismatch (True); 6026 end if; 6027 6028 elsif Ekind (E1) = E_Variable then 6029 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 6030 6031 elsif Ekind (E1) = E_Package then 6032 Check_Mismatch 6033 (Ekind (E1) /= Ekind (E2) 6034 or else Renamed_Object (E1) /= Renamed_Object (E2)); 6035 6036 elsif Is_Overloadable (E1) then 6037 6038 -- Verify that the actual subprograms match. Note that actuals 6039 -- that are attributes are rewritten as subprograms. If the 6040 -- subprogram in the formal package is defaulted, no check is 6041 -- needed. Note that this can only happen in Ada 2005 when the 6042 -- formal package can be partially parameterized. 6043 6044 if Nkind (Unit_Declaration_Node (E1)) = 6045 N_Subprogram_Renaming_Declaration 6046 and then From_Default (Unit_Declaration_Node (E1)) 6047 then 6048 null; 6049 6050 -- If the formal package has an "others" box association that 6051 -- covers this formal, there is no need for a check either. 6052 6053 elsif Nkind (Unit_Declaration_Node (E2)) in 6054 N_Formal_Subprogram_Declaration 6055 and then Box_Present (Unit_Declaration_Node (E2)) 6056 then 6057 null; 6058 6059 -- No check needed if subprogram is a defaulted null procedure 6060 6061 elsif No (Alias (E2)) 6062 and then Ekind (E2) = E_Procedure 6063 and then 6064 Null_Present (Specification (Unit_Declaration_Node (E2))) 6065 then 6066 null; 6067 6068 -- Otherwise the actual in the formal and the actual in the 6069 -- instantiation of the formal must match, up to renamings. 6070 6071 else 6072 Check_Mismatch 6073 (Ekind (E2) /= Ekind (E1) 6074 or else not Same_Instantiated_Function (E1, E2)); 6075 end if; 6076 6077 else 6078 raise Program_Error; 6079 end if; 6080 6081 <<Next_E>> 6082 Next_Entity (E1); 6083 Next_Entity (E2); 6084 end loop; 6085 end Check_Formal_Package_Instance; 6086 6087 --------------------------- 6088 -- Check_Formal_Packages -- 6089 --------------------------- 6090 6091 procedure Check_Formal_Packages (P_Id : Entity_Id) is 6092 E : Entity_Id; 6093 Formal_P : Entity_Id; 6094 Formal_Decl : Node_Id; 6095 6096 begin 6097 -- Iterate through the declarations in the instance, looking for package 6098 -- renaming declarations that denote instances of formal packages. Stop 6099 -- when we find the renaming of the current package itself. The 6100 -- declaration for a formal package without a box is followed by an 6101 -- internal entity that repeats the instantiation. 6102 6103 E := First_Entity (P_Id); 6104 while Present (E) loop 6105 if Ekind (E) = E_Package then 6106 if Renamed_Object (E) = P_Id then 6107 exit; 6108 6109 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6110 null; 6111 6112 else 6113 Formal_Decl := Parent (Associated_Formal_Package (E)); 6114 6115 -- Nothing to check if the formal has a box or an others_clause 6116 -- (necessarily with a box). 6117 6118 if Box_Present (Formal_Decl) then 6119 null; 6120 6121 elsif Nkind (First (Generic_Associations (Formal_Decl))) = 6122 N_Others_Choice 6123 then 6124 -- The internal validating package was generated but formal 6125 -- and instance are known to be compatible. 6126 6127 Formal_P := Next_Entity (E); 6128 Remove (Unit_Declaration_Node (Formal_P)); 6129 6130 else 6131 Formal_P := Next_Entity (E); 6132 Check_Formal_Package_Instance (Formal_P, E); 6133 6134 -- After checking, remove the internal validating package. 6135 -- It is only needed for semantic checks, and as it may 6136 -- contain generic formal declarations it should not reach 6137 -- gigi. 6138 6139 Remove (Unit_Declaration_Node (Formal_P)); 6140 end if; 6141 end if; 6142 end if; 6143 6144 Next_Entity (E); 6145 end loop; 6146 end Check_Formal_Packages; 6147 6148 --------------------------------- 6149 -- Check_Forward_Instantiation -- 6150 --------------------------------- 6151 6152 procedure Check_Forward_Instantiation (Decl : Node_Id) is 6153 S : Entity_Id; 6154 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 6155 6156 begin 6157 -- The instantiation appears before the generic body if we are in the 6158 -- scope of the unit containing the generic, either in its spec or in 6159 -- the package body, and before the generic body. 6160 6161 if Ekind (Gen_Comp) = E_Package_Body then 6162 Gen_Comp := Spec_Entity (Gen_Comp); 6163 end if; 6164 6165 if In_Open_Scopes (Gen_Comp) 6166 and then No (Corresponding_Body (Decl)) 6167 then 6168 S := Current_Scope; 6169 6170 while Present (S) 6171 and then not Is_Compilation_Unit (S) 6172 and then not Is_Child_Unit (S) 6173 loop 6174 if Ekind (S) = E_Package then 6175 Set_Has_Forward_Instantiation (S); 6176 end if; 6177 6178 S := Scope (S); 6179 end loop; 6180 end if; 6181 end Check_Forward_Instantiation; 6182 6183 --------------------------- 6184 -- Check_Generic_Actuals -- 6185 --------------------------- 6186 6187 -- The visibility of the actuals may be different between the point of 6188 -- generic instantiation and the instantiation of the body. 6189 6190 procedure Check_Generic_Actuals 6191 (Instance : Entity_Id; 6192 Is_Formal_Box : Boolean) 6193 is 6194 E : Entity_Id; 6195 Astype : Entity_Id; 6196 6197 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 6198 -- For a formal that is an array type, the component type is often a 6199 -- previous formal in the same unit. The privacy status of the component 6200 -- type will have been examined earlier in the traversal of the 6201 -- corresponding actuals, and this status should not be modified for 6202 -- the array (sub)type itself. However, if the base type of the array 6203 -- (sub)type is private, its full view must be restored in the body to 6204 -- be consistent with subsequent index subtypes, etc. 6205 -- 6206 -- To detect this case we have to rescan the list of formals, which is 6207 -- usually short enough to ignore the resulting inefficiency. 6208 6209 ----------------------------- 6210 -- Denotes_Previous_Actual -- 6211 ----------------------------- 6212 6213 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 6214 Prev : Entity_Id; 6215 6216 begin 6217 Prev := First_Entity (Instance); 6218 while Present (Prev) loop 6219 if Is_Type (Prev) 6220 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 6221 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 6222 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 6223 then 6224 return True; 6225 6226 elsif Prev = E then 6227 return False; 6228 6229 else 6230 Next_Entity (Prev); 6231 end if; 6232 end loop; 6233 6234 return False; 6235 end Denotes_Previous_Actual; 6236 6237 -- Start of processing for Check_Generic_Actuals 6238 6239 begin 6240 E := First_Entity (Instance); 6241 while Present (E) loop 6242 if Is_Type (E) 6243 and then Nkind (Parent (E)) = N_Subtype_Declaration 6244 and then Scope (Etype (E)) /= Instance 6245 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 6246 then 6247 if Is_Array_Type (E) 6248 and then not Is_Private_Type (Etype (E)) 6249 and then Denotes_Previous_Actual (Component_Type (E)) 6250 then 6251 null; 6252 else 6253 Check_Private_View (Subtype_Indication (Parent (E))); 6254 end if; 6255 6256 Set_Is_Generic_Actual_Type (E, True); 6257 Set_Is_Hidden (E, False); 6258 Set_Is_Potentially_Use_Visible (E, 6259 In_Use (Instance)); 6260 6261 -- We constructed the generic actual type as a subtype of the 6262 -- supplied type. This means that it normally would not inherit 6263 -- subtype specific attributes of the actual, which is wrong for 6264 -- the generic case. 6265 6266 Astype := Ancestor_Subtype (E); 6267 6268 if No (Astype) then 6269 6270 -- This can happen when E is an itype that is the full view of 6271 -- a private type completed, e.g. with a constrained array. In 6272 -- that case, use the first subtype, which will carry size 6273 -- information. The base type itself is unconstrained and will 6274 -- not carry it. 6275 6276 Astype := First_Subtype (E); 6277 end if; 6278 6279 Set_Size_Info (E, (Astype)); 6280 Set_RM_Size (E, RM_Size (Astype)); 6281 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 6282 6283 if Is_Discrete_Or_Fixed_Point_Type (E) then 6284 Set_RM_Size (E, RM_Size (Astype)); 6285 6286 -- In nested instances, the base type of an access actual may 6287 -- itself be private, and need to be exchanged. 6288 6289 elsif Is_Access_Type (E) 6290 and then Is_Private_Type (Etype (E)) 6291 then 6292 Check_Private_View 6293 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 6294 end if; 6295 6296 elsif Ekind (E) = E_Package then 6297 6298 -- If this is the renaming for the current instance, we're done. 6299 -- Otherwise it is a formal package. If the corresponding formal 6300 -- was declared with a box, the (instantiations of the) generic 6301 -- formal part are also visible. Otherwise, ignore the entity 6302 -- created to validate the actuals. 6303 6304 if Renamed_Object (E) = Instance then 6305 exit; 6306 6307 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6308 null; 6309 6310 -- The visibility of a formal of an enclosing generic is already 6311 -- correct. 6312 6313 elsif Denotes_Formal_Package (E) then 6314 null; 6315 6316 elsif Present (Associated_Formal_Package (E)) 6317 and then not Is_Generic_Formal (E) 6318 then 6319 if Box_Present (Parent (Associated_Formal_Package (E))) then 6320 Check_Generic_Actuals (Renamed_Object (E), True); 6321 6322 else 6323 Check_Generic_Actuals (Renamed_Object (E), False); 6324 end if; 6325 6326 Set_Is_Hidden (E, False); 6327 end if; 6328 6329 -- If this is a subprogram instance (in a wrapper package) the 6330 -- actual is fully visible. 6331 6332 elsif Is_Wrapper_Package (Instance) then 6333 Set_Is_Hidden (E, False); 6334 6335 -- If the formal package is declared with a box, or if the formal 6336 -- parameter is defaulted, it is visible in the body. 6337 6338 elsif Is_Formal_Box or else Is_Visible_Formal (E) then 6339 Set_Is_Hidden (E, False); 6340 end if; 6341 6342 if Ekind (E) = E_Constant then 6343 6344 -- If the type of the actual is a private type declared in the 6345 -- enclosing scope of the generic unit, the body of the generic 6346 -- sees the full view of the type (because it has to appear in 6347 -- the corresponding package body). If the type is private now, 6348 -- exchange views to restore the proper visiblity in the instance. 6349 6350 declare 6351 Typ : constant Entity_Id := Base_Type (Etype (E)); 6352 -- The type of the actual 6353 6354 Gen_Id : Entity_Id; 6355 -- The generic unit 6356 6357 Parent_Scope : Entity_Id; 6358 -- The enclosing scope of the generic unit 6359 6360 begin 6361 if Is_Wrapper_Package (Instance) then 6362 Gen_Id := 6363 Generic_Parent 6364 (Specification 6365 (Unit_Declaration_Node 6366 (Related_Instance (Instance)))); 6367 else 6368 Gen_Id := 6369 Generic_Parent (Package_Specification (Instance)); 6370 end if; 6371 6372 Parent_Scope := Scope (Gen_Id); 6373 6374 -- The exchange is only needed if the generic is defined 6375 -- within a package which is not a common ancestor of the 6376 -- scope of the instance, and is not already in scope. 6377 6378 if Is_Private_Type (Typ) 6379 and then Scope (Typ) = Parent_Scope 6380 and then Scope (Instance) /= Parent_Scope 6381 and then Ekind (Parent_Scope) = E_Package 6382 and then not Is_Child_Unit (Gen_Id) 6383 then 6384 Switch_View (Typ); 6385 6386 -- If the type of the entity is a subtype, it may also have 6387 -- to be made visible, together with the base type of its 6388 -- full view, after exchange. 6389 6390 if Is_Private_Type (Etype (E)) then 6391 Switch_View (Etype (E)); 6392 Switch_View (Base_Type (Etype (E))); 6393 end if; 6394 end if; 6395 end; 6396 end if; 6397 6398 Next_Entity (E); 6399 end loop; 6400 end Check_Generic_Actuals; 6401 6402 ------------------------------ 6403 -- Check_Generic_Child_Unit -- 6404 ------------------------------ 6405 6406 procedure Check_Generic_Child_Unit 6407 (Gen_Id : Node_Id; 6408 Parent_Installed : in out Boolean) 6409 is 6410 Loc : constant Source_Ptr := Sloc (Gen_Id); 6411 Gen_Par : Entity_Id := Empty; 6412 E : Entity_Id; 6413 Inst_Par : Entity_Id; 6414 S : Node_Id; 6415 6416 function Find_Generic_Child 6417 (Scop : Entity_Id; 6418 Id : Node_Id) return Entity_Id; 6419 -- Search generic parent for possible child unit with the given name 6420 6421 function In_Enclosing_Instance return Boolean; 6422 -- Within an instance of the parent, the child unit may be denoted by 6423 -- a simple name, or an abbreviated expanded name. Examine enclosing 6424 -- scopes to locate a possible parent instantiation. 6425 6426 ------------------------ 6427 -- Find_Generic_Child -- 6428 ------------------------ 6429 6430 function Find_Generic_Child 6431 (Scop : Entity_Id; 6432 Id : Node_Id) return Entity_Id 6433 is 6434 E : Entity_Id; 6435 6436 begin 6437 -- If entity of name is already set, instance has already been 6438 -- resolved, e.g. in an enclosing instantiation. 6439 6440 if Present (Entity (Id)) then 6441 if Scope (Entity (Id)) = Scop then 6442 return Entity (Id); 6443 else 6444 return Empty; 6445 end if; 6446 6447 else 6448 E := First_Entity (Scop); 6449 while Present (E) loop 6450 if Chars (E) = Chars (Id) 6451 and then Is_Child_Unit (E) 6452 then 6453 if Is_Child_Unit (E) 6454 and then not Is_Visible_Lib_Unit (E) 6455 then 6456 Error_Msg_NE 6457 ("generic child unit& is not visible", Gen_Id, E); 6458 end if; 6459 6460 Set_Entity (Id, E); 6461 return E; 6462 end if; 6463 6464 Next_Entity (E); 6465 end loop; 6466 6467 return Empty; 6468 end if; 6469 end Find_Generic_Child; 6470 6471 --------------------------- 6472 -- In_Enclosing_Instance -- 6473 --------------------------- 6474 6475 function In_Enclosing_Instance return Boolean is 6476 Enclosing_Instance : Node_Id; 6477 Instance_Decl : Node_Id; 6478 6479 begin 6480 -- We do not inline any call that contains instantiations, except 6481 -- for instantiations of Unchecked_Conversion, so if we are within 6482 -- an inlined body the current instance does not require parents. 6483 6484 if In_Inlined_Body then 6485 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 6486 return False; 6487 end if; 6488 6489 -- Loop to check enclosing scopes 6490 6491 Enclosing_Instance := Current_Scope; 6492 while Present (Enclosing_Instance) loop 6493 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 6494 6495 if Ekind (Enclosing_Instance) = E_Package 6496 and then Is_Generic_Instance (Enclosing_Instance) 6497 and then Present 6498 (Generic_Parent (Specification (Instance_Decl))) 6499 then 6500 -- Check whether the generic we are looking for is a child of 6501 -- this instance. 6502 6503 E := Find_Generic_Child 6504 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 6505 exit when Present (E); 6506 6507 else 6508 E := Empty; 6509 end if; 6510 6511 Enclosing_Instance := Scope (Enclosing_Instance); 6512 end loop; 6513 6514 if No (E) then 6515 6516 -- Not a child unit 6517 6518 Analyze (Gen_Id); 6519 return False; 6520 6521 else 6522 Rewrite (Gen_Id, 6523 Make_Expanded_Name (Loc, 6524 Chars => Chars (E), 6525 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 6526 Selector_Name => New_Occurrence_Of (E, Loc))); 6527 6528 Set_Entity (Gen_Id, E); 6529 Set_Etype (Gen_Id, Etype (E)); 6530 Parent_Installed := False; -- Already in scope. 6531 return True; 6532 end if; 6533 end In_Enclosing_Instance; 6534 6535 -- Start of processing for Check_Generic_Child_Unit 6536 6537 begin 6538 -- If the name of the generic is given by a selected component, it may 6539 -- be the name of a generic child unit, and the prefix is the name of an 6540 -- instance of the parent, in which case the child unit must be visible. 6541 -- If this instance is not in scope, it must be placed there and removed 6542 -- after instantiation, because what is being instantiated is not the 6543 -- original child, but the corresponding child present in the instance 6544 -- of the parent. 6545 6546 -- If the child is instantiated within the parent, it can be given by 6547 -- a simple name. In this case the instance is already in scope, but 6548 -- the child generic must be recovered from the generic parent as well. 6549 6550 if Nkind (Gen_Id) = N_Selected_Component then 6551 S := Selector_Name (Gen_Id); 6552 Analyze (Prefix (Gen_Id)); 6553 Inst_Par := Entity (Prefix (Gen_Id)); 6554 6555 if Ekind (Inst_Par) = E_Package 6556 and then Present (Renamed_Object (Inst_Par)) 6557 then 6558 Inst_Par := Renamed_Object (Inst_Par); 6559 end if; 6560 6561 if Ekind (Inst_Par) = E_Package then 6562 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 6563 Gen_Par := Generic_Parent (Parent (Inst_Par)); 6564 6565 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 6566 and then 6567 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 6568 then 6569 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 6570 end if; 6571 6572 elsif Ekind (Inst_Par) = E_Generic_Package 6573 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 6574 then 6575 -- A formal package may be a real child package, and not the 6576 -- implicit instance within a parent. In this case the child is 6577 -- not visible and has to be retrieved explicitly as well. 6578 6579 Gen_Par := Inst_Par; 6580 end if; 6581 6582 if Present (Gen_Par) then 6583 6584 -- The prefix denotes an instantiation. The entity itself may be a 6585 -- nested generic, or a child unit. 6586 6587 E := Find_Generic_Child (Gen_Par, S); 6588 6589 if Present (E) then 6590 Change_Selected_Component_To_Expanded_Name (Gen_Id); 6591 Set_Entity (Gen_Id, E); 6592 Set_Etype (Gen_Id, Etype (E)); 6593 Set_Entity (S, E); 6594 Set_Etype (S, Etype (E)); 6595 6596 -- Indicate that this is a reference to the parent 6597 6598 if In_Extended_Main_Source_Unit (Gen_Id) then 6599 Set_Is_Instantiated (Inst_Par); 6600 end if; 6601 6602 -- A common mistake is to replicate the naming scheme of a 6603 -- hierarchy by instantiating a generic child directly, rather 6604 -- than the implicit child in a parent instance: 6605 6606 -- generic .. package Gpar is .. 6607 -- generic .. package Gpar.Child is .. 6608 -- package Par is new Gpar (); 6609 6610 -- with Gpar.Child; 6611 -- package Par.Child is new Gpar.Child (); 6612 -- rather than Par.Child 6613 6614 -- In this case the instantiation is within Par, which is an 6615 -- instance, but Gpar does not denote Par because we are not IN 6616 -- the instance of Gpar, so this is illegal. The test below 6617 -- recognizes this particular case. 6618 6619 if Is_Child_Unit (E) 6620 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 6621 and then (not In_Instance 6622 or else Nkind (Parent (Parent (Gen_Id))) = 6623 N_Compilation_Unit) 6624 then 6625 Error_Msg_N 6626 ("prefix of generic child unit must be instance of parent", 6627 Gen_Id); 6628 end if; 6629 6630 if not In_Open_Scopes (Inst_Par) 6631 and then Nkind (Parent (Gen_Id)) not in 6632 N_Generic_Renaming_Declaration 6633 then 6634 Install_Parent (Inst_Par); 6635 Parent_Installed := True; 6636 6637 elsif In_Open_Scopes (Inst_Par) then 6638 6639 -- If the parent is already installed, install the actuals 6640 -- for its formal packages. This is necessary when the child 6641 -- instance is a child of the parent instance: in this case, 6642 -- the parent is placed on the scope stack but the formal 6643 -- packages are not made visible. 6644 6645 Install_Formal_Packages (Inst_Par); 6646 end if; 6647 6648 else 6649 -- If the generic parent does not contain an entity that 6650 -- corresponds to the selector, the instance doesn't either. 6651 -- Analyzing the node will yield the appropriate error message. 6652 -- If the entity is not a child unit, then it is an inner 6653 -- generic in the parent. 6654 6655 Analyze (Gen_Id); 6656 end if; 6657 6658 else 6659 Analyze (Gen_Id); 6660 6661 if Is_Child_Unit (Entity (Gen_Id)) 6662 and then 6663 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 6664 and then not In_Open_Scopes (Inst_Par) 6665 then 6666 Install_Parent (Inst_Par); 6667 Parent_Installed := True; 6668 6669 -- The generic unit may be the renaming of the implicit child 6670 -- present in an instance. In that case the parent instance is 6671 -- obtained from the name of the renamed entity. 6672 6673 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 6674 and then Present (Renamed_Entity (Entity (Gen_Id))) 6675 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 6676 then 6677 declare 6678 Renamed_Package : constant Node_Id := 6679 Name (Parent (Entity (Gen_Id))); 6680 begin 6681 if Nkind (Renamed_Package) = N_Expanded_Name then 6682 Inst_Par := Entity (Prefix (Renamed_Package)); 6683 Install_Parent (Inst_Par); 6684 Parent_Installed := True; 6685 end if; 6686 end; 6687 end if; 6688 end if; 6689 6690 elsif Nkind (Gen_Id) = N_Expanded_Name then 6691 6692 -- Entity already present, analyze prefix, whose meaning may be 6693 -- an instance in the current context. If it is an instance of 6694 -- a relative within another, the proper parent may still have 6695 -- to be installed, if they are not of the same generation. 6696 6697 Analyze (Prefix (Gen_Id)); 6698 6699 -- In the unlikely case that a local declaration hides the name 6700 -- of the parent package, locate it on the homonym chain. If the 6701 -- context is an instance of the parent, the renaming entity is 6702 -- flagged as such. 6703 6704 Inst_Par := Entity (Prefix (Gen_Id)); 6705 while Present (Inst_Par) 6706 and then not Is_Package_Or_Generic_Package (Inst_Par) 6707 loop 6708 Inst_Par := Homonym (Inst_Par); 6709 end loop; 6710 6711 pragma Assert (Present (Inst_Par)); 6712 Set_Entity (Prefix (Gen_Id), Inst_Par); 6713 6714 if In_Enclosing_Instance then 6715 null; 6716 6717 elsif Present (Entity (Gen_Id)) 6718 and then Is_Child_Unit (Entity (Gen_Id)) 6719 and then not In_Open_Scopes (Inst_Par) 6720 then 6721 Install_Parent (Inst_Par); 6722 Parent_Installed := True; 6723 end if; 6724 6725 elsif In_Enclosing_Instance then 6726 6727 -- The child unit is found in some enclosing scope 6728 6729 null; 6730 6731 else 6732 Analyze (Gen_Id); 6733 6734 -- If this is the renaming of the implicit child in a parent 6735 -- instance, recover the parent name and install it. 6736 6737 if Is_Entity_Name (Gen_Id) then 6738 E := Entity (Gen_Id); 6739 6740 if Is_Generic_Unit (E) 6741 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 6742 and then Is_Child_Unit (Renamed_Object (E)) 6743 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 6744 and then Nkind (Name (Parent (E))) = N_Expanded_Name 6745 then 6746 Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E)))); 6747 Inst_Par := Entity (Prefix (Gen_Id)); 6748 6749 if not In_Open_Scopes (Inst_Par) then 6750 Install_Parent (Inst_Par); 6751 Parent_Installed := True; 6752 end if; 6753 6754 -- If it is a child unit of a non-generic parent, it may be 6755 -- use-visible and given by a direct name. Install parent as 6756 -- for other cases. 6757 6758 elsif Is_Generic_Unit (E) 6759 and then Is_Child_Unit (E) 6760 and then 6761 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 6762 and then not Is_Generic_Unit (Scope (E)) 6763 then 6764 if not In_Open_Scopes (Scope (E)) then 6765 Install_Parent (Scope (E)); 6766 Parent_Installed := True; 6767 end if; 6768 end if; 6769 end if; 6770 end if; 6771 end Check_Generic_Child_Unit; 6772 6773 ----------------------------- 6774 -- Check_Hidden_Child_Unit -- 6775 ----------------------------- 6776 6777 procedure Check_Hidden_Child_Unit 6778 (N : Node_Id; 6779 Gen_Unit : Entity_Id; 6780 Act_Decl_Id : Entity_Id) 6781 is 6782 Gen_Id : constant Node_Id := Name (N); 6783 6784 begin 6785 if Is_Child_Unit (Gen_Unit) 6786 and then Is_Child_Unit (Act_Decl_Id) 6787 and then Nkind (Gen_Id) = N_Expanded_Name 6788 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 6789 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 6790 then 6791 Error_Msg_Node_2 := Scope (Act_Decl_Id); 6792 Error_Msg_NE 6793 ("generic unit & is implicitly declared in &", 6794 Defining_Unit_Name (N), Gen_Unit); 6795 Error_Msg_N ("\instance must have different name", 6796 Defining_Unit_Name (N)); 6797 end if; 6798 end Check_Hidden_Child_Unit; 6799 6800 ------------------------ 6801 -- Check_Private_View -- 6802 ------------------------ 6803 6804 procedure Check_Private_View (N : Node_Id) is 6805 T : constant Entity_Id := Etype (N); 6806 BT : Entity_Id; 6807 6808 begin 6809 -- Exchange views if the type was not private in the generic but is 6810 -- private at the point of instantiation. Do not exchange views if 6811 -- the scope of the type is in scope. This can happen if both generic 6812 -- and instance are sibling units, or if type is defined in a parent. 6813 -- In this case the visibility of the type will be correct for all 6814 -- semantic checks. 6815 6816 if Present (T) then 6817 BT := Base_Type (T); 6818 6819 if Is_Private_Type (T) 6820 and then not Has_Private_View (N) 6821 and then Present (Full_View (T)) 6822 and then not In_Open_Scopes (Scope (T)) 6823 then 6824 -- In the generic, the full type was visible. Save the private 6825 -- entity, for subsequent exchange. 6826 6827 Switch_View (T); 6828 6829 elsif Has_Private_View (N) 6830 and then not Is_Private_Type (T) 6831 and then not Has_Been_Exchanged (T) 6832 and then Etype (Get_Associated_Node (N)) /= T 6833 then 6834 -- Only the private declaration was visible in the generic. If 6835 -- the type appears in a subtype declaration, the subtype in the 6836 -- instance must have a view compatible with that of its parent, 6837 -- which must be exchanged (see corresponding code in Restore_ 6838 -- Private_Views). Otherwise, if the type is defined in a parent 6839 -- unit, leave full visibility within instance, which is safe. 6840 6841 if In_Open_Scopes (Scope (Base_Type (T))) 6842 and then not Is_Private_Type (Base_Type (T)) 6843 and then Comes_From_Source (Base_Type (T)) 6844 then 6845 null; 6846 6847 elsif Nkind (Parent (N)) = N_Subtype_Declaration 6848 or else not In_Private_Part (Scope (Base_Type (T))) 6849 then 6850 Prepend_Elmt (T, Exchanged_Views); 6851 Exchange_Declarations (Etype (Get_Associated_Node (N))); 6852 end if; 6853 6854 -- For composite types with inconsistent representation exchange 6855 -- component types accordingly. 6856 6857 elsif Is_Access_Type (T) 6858 and then Is_Private_Type (Designated_Type (T)) 6859 and then not Has_Private_View (N) 6860 and then Present (Full_View (Designated_Type (T))) 6861 then 6862 Switch_View (Designated_Type (T)); 6863 6864 elsif Is_Array_Type (T) then 6865 if Is_Private_Type (Component_Type (T)) 6866 and then not Has_Private_View (N) 6867 and then Present (Full_View (Component_Type (T))) 6868 then 6869 Switch_View (Component_Type (T)); 6870 end if; 6871 6872 -- The normal exchange mechanism relies on the setting of a 6873 -- flag on the reference in the generic. However, an additional 6874 -- mechanism is needed for types that are not explicitly 6875 -- mentioned in the generic, but may be needed in expanded code 6876 -- in the instance. This includes component types of arrays and 6877 -- designated types of access types. This processing must also 6878 -- include the index types of arrays which we take care of here. 6879 6880 declare 6881 Indx : Node_Id; 6882 Typ : Entity_Id; 6883 6884 begin 6885 Indx := First_Index (T); 6886 while Present (Indx) loop 6887 Typ := Base_Type (Etype (Indx)); 6888 6889 if Is_Private_Type (Typ) 6890 and then Present (Full_View (Typ)) 6891 then 6892 Switch_View (Typ); 6893 end if; 6894 6895 Next_Index (Indx); 6896 end loop; 6897 end; 6898 6899 elsif Is_Private_Type (T) 6900 and then Present (Full_View (T)) 6901 and then Is_Array_Type (Full_View (T)) 6902 and then Is_Private_Type (Component_Type (Full_View (T))) 6903 then 6904 Switch_View (T); 6905 6906 -- Finally, a non-private subtype may have a private base type, which 6907 -- must be exchanged for consistency. This can happen when a package 6908 -- body is instantiated, when the scope stack is empty but in fact 6909 -- the subtype and the base type are declared in an enclosing scope. 6910 6911 -- Note that in this case we introduce an inconsistency in the view 6912 -- set, because we switch the base type BT, but there could be some 6913 -- private dependent subtypes of BT which remain unswitched. Such 6914 -- subtypes might need to be switched at a later point (see specific 6915 -- provision for that case in Switch_View). 6916 6917 elsif not Is_Private_Type (T) 6918 and then not Has_Private_View (N) 6919 and then Is_Private_Type (BT) 6920 and then Present (Full_View (BT)) 6921 and then not Is_Generic_Type (BT) 6922 and then not In_Open_Scopes (BT) 6923 then 6924 Prepend_Elmt (Full_View (BT), Exchanged_Views); 6925 Exchange_Declarations (BT); 6926 end if; 6927 end if; 6928 end Check_Private_View; 6929 6930 ----------------------------- 6931 -- Check_Hidden_Primitives -- 6932 ----------------------------- 6933 6934 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 6935 Actual : Node_Id; 6936 Gen_T : Entity_Id; 6937 Result : Elist_Id := No_Elist; 6938 6939 begin 6940 if No (Assoc_List) then 6941 return No_Elist; 6942 end if; 6943 6944 -- Traverse the list of associations between formals and actuals 6945 -- searching for renamings of tagged types 6946 6947 Actual := First (Assoc_List); 6948 while Present (Actual) loop 6949 if Nkind (Actual) = N_Subtype_Declaration then 6950 Gen_T := Generic_Parent_Type (Actual); 6951 6952 if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then 6953 6954 -- Traverse the list of primitives of the actual types 6955 -- searching for hidden primitives that are visible in the 6956 -- corresponding generic formal; leave them visible and 6957 -- append them to Result to restore their decoration later. 6958 6959 Install_Hidden_Primitives 6960 (Prims_List => Result, 6961 Gen_T => Gen_T, 6962 Act_T => Entity (Subtype_Indication (Actual))); 6963 end if; 6964 end if; 6965 6966 Next (Actual); 6967 end loop; 6968 6969 return Result; 6970 end Check_Hidden_Primitives; 6971 6972 -------------------------- 6973 -- Contains_Instance_Of -- 6974 -------------------------- 6975 6976 function Contains_Instance_Of 6977 (Inner : Entity_Id; 6978 Outer : Entity_Id; 6979 N : Node_Id) return Boolean 6980 is 6981 Elmt : Elmt_Id; 6982 Scop : Entity_Id; 6983 6984 begin 6985 Scop := Outer; 6986 6987 -- Verify that there are no circular instantiations. We check whether 6988 -- the unit contains an instance of the current scope or some enclosing 6989 -- scope (in case one of the instances appears in a subunit). Longer 6990 -- circularities involving subunits might seem too pathological to 6991 -- consider, but they were not too pathological for the authors of 6992 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 6993 -- enclosing generic scopes as containing an instance. 6994 6995 loop 6996 -- Within a generic subprogram body, the scope is not generic, to 6997 -- allow for recursive subprograms. Use the declaration to determine 6998 -- whether this is a generic unit. 6999 7000 if Ekind (Scop) = E_Generic_Package 7001 or else (Is_Subprogram (Scop) 7002 and then Nkind (Unit_Declaration_Node (Scop)) = 7003 N_Generic_Subprogram_Declaration) 7004 then 7005 Elmt := First_Elmt (Inner_Instances (Inner)); 7006 7007 while Present (Elmt) loop 7008 if Node (Elmt) = Scop then 7009 Error_Msg_Node_2 := Inner; 7010 Error_Msg_NE 7011 ("circular Instantiation: & instantiated within &!", 7012 N, Scop); 7013 return True; 7014 7015 elsif Node (Elmt) = Inner then 7016 return True; 7017 7018 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 7019 Error_Msg_Node_2 := Inner; 7020 Error_Msg_NE 7021 ("circular Instantiation: & instantiated within &!", 7022 N, Node (Elmt)); 7023 return True; 7024 end if; 7025 7026 Next_Elmt (Elmt); 7027 end loop; 7028 7029 -- Indicate that Inner is being instantiated within Scop 7030 7031 Append_Elmt (Inner, Inner_Instances (Scop)); 7032 end if; 7033 7034 if Scop = Standard_Standard then 7035 exit; 7036 else 7037 Scop := Scope (Scop); 7038 end if; 7039 end loop; 7040 7041 return False; 7042 end Contains_Instance_Of; 7043 7044 ----------------------- 7045 -- Copy_Generic_Node -- 7046 ----------------------- 7047 7048 function Copy_Generic_Node 7049 (N : Node_Id; 7050 Parent_Id : Node_Id; 7051 Instantiating : Boolean) return Node_Id 7052 is 7053 Ent : Entity_Id; 7054 New_N : Node_Id; 7055 7056 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 7057 -- Check the given value of one of the Fields referenced by the current 7058 -- node to determine whether to copy it recursively. The field may hold 7059 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, 7060 -- Char) in which case it need not be copied. 7061 7062 procedure Copy_Descendants; 7063 -- Common utility for various nodes 7064 7065 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 7066 -- Make copy of element list 7067 7068 function Copy_Generic_List 7069 (L : List_Id; 7070 Parent_Id : Node_Id) return List_Id; 7071 -- Apply Copy_Node recursively to the members of a node list 7072 7073 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 7074 -- True if an identifier is part of the defining program unit name of 7075 -- a child unit. The entity of such an identifier must be kept (for 7076 -- ASIS use) even though as the name of an enclosing generic it would 7077 -- otherwise not be preserved in the generic tree. 7078 7079 ---------------------- 7080 -- Copy_Descendants -- 7081 ---------------------- 7082 7083 procedure Copy_Descendants is 7084 use Atree.Unchecked_Access; 7085 -- This code section is part of the implementation of an untyped 7086 -- tree traversal, so it needs direct access to node fields. 7087 7088 begin 7089 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 7090 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 7091 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 7092 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 7093 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 7094 end Copy_Descendants; 7095 7096 ----------------------------- 7097 -- Copy_Generic_Descendant -- 7098 ----------------------------- 7099 7100 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 7101 begin 7102 if D = Union_Id (Empty) then 7103 return D; 7104 7105 elsif D in Node_Range then 7106 return Union_Id 7107 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 7108 7109 elsif D in List_Range then 7110 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 7111 7112 elsif D in Elist_Range then 7113 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 7114 7115 -- Nothing else is copyable (e.g. Uint values), return as is 7116 7117 else 7118 return D; 7119 end if; 7120 end Copy_Generic_Descendant; 7121 7122 ------------------------ 7123 -- Copy_Generic_Elist -- 7124 ------------------------ 7125 7126 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 7127 M : Elmt_Id; 7128 L : Elist_Id; 7129 7130 begin 7131 if Present (E) then 7132 L := New_Elmt_List; 7133 M := First_Elmt (E); 7134 while Present (M) loop 7135 Append_Elmt 7136 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 7137 Next_Elmt (M); 7138 end loop; 7139 7140 return L; 7141 7142 else 7143 return No_Elist; 7144 end if; 7145 end Copy_Generic_Elist; 7146 7147 ----------------------- 7148 -- Copy_Generic_List -- 7149 ----------------------- 7150 7151 function Copy_Generic_List 7152 (L : List_Id; 7153 Parent_Id : Node_Id) return List_Id 7154 is 7155 N : Node_Id; 7156 New_L : List_Id; 7157 7158 begin 7159 if Present (L) then 7160 New_L := New_List; 7161 Set_Parent (New_L, Parent_Id); 7162 7163 N := First (L); 7164 while Present (N) loop 7165 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 7166 Next (N); 7167 end loop; 7168 7169 return New_L; 7170 7171 else 7172 return No_List; 7173 end if; 7174 end Copy_Generic_List; 7175 7176 --------------------------- 7177 -- In_Defining_Unit_Name -- 7178 --------------------------- 7179 7180 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 7181 begin 7182 return 7183 Present (Parent (Nam)) 7184 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 7185 or else 7186 (Nkind (Parent (Nam)) = N_Expanded_Name 7187 and then In_Defining_Unit_Name (Parent (Nam)))); 7188 end In_Defining_Unit_Name; 7189 7190 -- Start of processing for Copy_Generic_Node 7191 7192 begin 7193 if N = Empty then 7194 return N; 7195 end if; 7196 7197 New_N := New_Copy (N); 7198 7199 -- Copy aspects if present 7200 7201 if Has_Aspects (N) then 7202 Set_Has_Aspects (New_N, False); 7203 Set_Aspect_Specifications 7204 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 7205 end if; 7206 7207 if Instantiating then 7208 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 7209 end if; 7210 7211 if not Is_List_Member (N) then 7212 Set_Parent (New_N, Parent_Id); 7213 end if; 7214 7215 -- Special casing for identifiers and other entity names and operators 7216 7217 if Nkind_In (New_N, N_Character_Literal, 7218 N_Expanded_Name, 7219 N_Identifier, 7220 N_Operator_Symbol) 7221 or else Nkind (New_N) in N_Op 7222 then 7223 if not Instantiating then 7224 7225 -- Link both nodes in order to assign subsequently the entity of 7226 -- the copy to the original node, in case this is a global 7227 -- reference. 7228 7229 Set_Associated_Node (N, New_N); 7230 7231 -- If we are within an instantiation, this is a nested generic 7232 -- that has already been analyzed at the point of definition. 7233 -- We must preserve references that were global to the enclosing 7234 -- parent at that point. Other occurrences, whether global or 7235 -- local to the current generic, must be resolved anew, so we 7236 -- reset the entity in the generic copy. A global reference has a 7237 -- smaller depth than the parent, or else the same depth in case 7238 -- both are distinct compilation units. 7239 7240 -- A child unit is implicitly declared within the enclosing parent 7241 -- but is in fact global to it, and must be preserved. 7242 7243 -- It is also possible for Current_Instantiated_Parent to be 7244 -- defined, and for this not to be a nested generic, namely if 7245 -- the unit is loaded through Rtsfind. In that case, the entity of 7246 -- New_N is only a link to the associated node, and not a defining 7247 -- occurrence. 7248 7249 -- The entities for parent units in the defining_program_unit of a 7250 -- generic child unit are established when the context of the unit 7251 -- is first analyzed, before the generic copy is made. They are 7252 -- preserved in the copy for use in ASIS queries. 7253 7254 Ent := Entity (New_N); 7255 7256 if No (Current_Instantiated_Parent.Gen_Id) then 7257 if No (Ent) 7258 or else Nkind (Ent) /= N_Defining_Identifier 7259 or else not In_Defining_Unit_Name (N) 7260 then 7261 Set_Associated_Node (New_N, Empty); 7262 end if; 7263 7264 elsif No (Ent) 7265 or else 7266 not Nkind_In (Ent, N_Defining_Identifier, 7267 N_Defining_Character_Literal, 7268 N_Defining_Operator_Symbol) 7269 or else No (Scope (Ent)) 7270 or else 7271 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 7272 and then not Is_Child_Unit (Ent)) 7273 or else 7274 (Scope_Depth (Scope (Ent)) > 7275 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 7276 and then 7277 Get_Source_Unit (Ent) = 7278 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 7279 then 7280 Set_Associated_Node (New_N, Empty); 7281 end if; 7282 7283 -- Case of instantiating identifier or some other name or operator 7284 7285 else 7286 -- If the associated node is still defined, the entity in it 7287 -- is global, and must be copied to the instance. If this copy 7288 -- is being made for a body to inline, it is applied to an 7289 -- instantiated tree, and the entity is already present and 7290 -- must be also preserved. 7291 7292 declare 7293 Assoc : constant Node_Id := Get_Associated_Node (N); 7294 7295 begin 7296 if Present (Assoc) then 7297 if Nkind (Assoc) = Nkind (N) then 7298 Set_Entity (New_N, Entity (Assoc)); 7299 Check_Private_View (N); 7300 7301 -- The name in the call may be a selected component if the 7302 -- call has not been analyzed yet, as may be the case for 7303 -- pre/post conditions in a generic unit. 7304 7305 elsif Nkind (Assoc) = N_Function_Call 7306 and then Is_Entity_Name (Name (Assoc)) 7307 then 7308 Set_Entity (New_N, Entity (Name (Assoc))); 7309 7310 elsif Nkind_In (Assoc, N_Defining_Identifier, 7311 N_Defining_Character_Literal, 7312 N_Defining_Operator_Symbol) 7313 and then Expander_Active 7314 then 7315 -- Inlining case: we are copying a tree that contains 7316 -- global entities, which are preserved in the copy to be 7317 -- used for subsequent inlining. 7318 7319 null; 7320 7321 else 7322 Set_Entity (New_N, Empty); 7323 end if; 7324 end if; 7325 end; 7326 end if; 7327 7328 -- For expanded name, we must copy the Prefix and Selector_Name 7329 7330 if Nkind (N) = N_Expanded_Name then 7331 Set_Prefix 7332 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 7333 7334 Set_Selector_Name (New_N, 7335 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 7336 7337 -- For operators, we must copy the right operand 7338 7339 elsif Nkind (N) in N_Op then 7340 Set_Right_Opnd (New_N, 7341 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 7342 7343 -- And for binary operators, the left operand as well 7344 7345 if Nkind (N) in N_Binary_Op then 7346 Set_Left_Opnd (New_N, 7347 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 7348 end if; 7349 end if; 7350 7351 -- Establish a link between an entity from the generic template and the 7352 -- corresponding entity in the generic copy to be analyzed. 7353 7354 elsif Nkind (N) in N_Entity then 7355 if not Instantiating then 7356 Set_Associated_Entity (N, New_N); 7357 end if; 7358 7359 -- Clear any existing link the copy may inherit from the replicated 7360 -- generic template entity. 7361 7362 Set_Associated_Entity (New_N, Empty); 7363 7364 -- Special casing for stubs 7365 7366 elsif Nkind (N) in N_Body_Stub then 7367 7368 -- In any case, we must copy the specification or defining 7369 -- identifier as appropriate. 7370 7371 if Nkind (N) = N_Subprogram_Body_Stub then 7372 Set_Specification (New_N, 7373 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 7374 7375 else 7376 Set_Defining_Identifier (New_N, 7377 Copy_Generic_Node 7378 (Defining_Identifier (N), New_N, Instantiating)); 7379 end if; 7380 7381 -- If we are not instantiating, then this is where we load and 7382 -- analyze subunits, i.e. at the point where the stub occurs. A 7383 -- more permissive system might defer this analysis to the point 7384 -- of instantiation, but this seems too complicated for now. 7385 7386 if not Instantiating then 7387 declare 7388 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 7389 Subunit : Node_Id; 7390 Unum : Unit_Number_Type; 7391 New_Body : Node_Id; 7392 7393 begin 7394 -- Make sure that, if it is a subunit of the main unit that is 7395 -- preprocessed and if -gnateG is specified, the preprocessed 7396 -- file will be written. 7397 7398 Lib.Analysing_Subunit_Of_Main := 7399 Lib.In_Extended_Main_Source_Unit (N); 7400 Unum := 7401 Load_Unit 7402 (Load_Name => Subunit_Name, 7403 Required => False, 7404 Subunit => True, 7405 Error_Node => N); 7406 Lib.Analysing_Subunit_Of_Main := False; 7407 7408 -- If the proper body is not found, a warning message will be 7409 -- emitted when analyzing the stub, or later at the point of 7410 -- instantiation. Here we just leave the stub as is. 7411 7412 if Unum = No_Unit then 7413 Subunits_Missing := True; 7414 goto Subunit_Not_Found; 7415 end if; 7416 7417 Subunit := Cunit (Unum); 7418 7419 if Nkind (Unit (Subunit)) /= N_Subunit then 7420 Error_Msg_N 7421 ("found child unit instead of expected SEPARATE subunit", 7422 Subunit); 7423 Error_Msg_Sloc := Sloc (N); 7424 Error_Msg_N ("\to complete stub #", Subunit); 7425 goto Subunit_Not_Found; 7426 end if; 7427 7428 -- We must create a generic copy of the subunit, in order to 7429 -- perform semantic analysis on it, and we must replace the 7430 -- stub in the original generic unit with the subunit, in order 7431 -- to preserve non-local references within. 7432 7433 -- Only the proper body needs to be copied. Library_Unit and 7434 -- context clause are simply inherited by the generic copy. 7435 -- Note that the copy (which may be recursive if there are 7436 -- nested subunits) must be done first, before attaching it to 7437 -- the enclosing generic. 7438 7439 New_Body := 7440 Copy_Generic_Node 7441 (Proper_Body (Unit (Subunit)), 7442 Empty, Instantiating => False); 7443 7444 -- Now place the original proper body in the original generic 7445 -- unit. This is a body, not a compilation unit. 7446 7447 Rewrite (N, Proper_Body (Unit (Subunit))); 7448 Set_Is_Compilation_Unit (Defining_Entity (N), False); 7449 Set_Was_Originally_Stub (N); 7450 7451 -- Finally replace the body of the subunit with its copy, and 7452 -- make this new subunit into the library unit of the generic 7453 -- copy, which does not have stubs any longer. 7454 7455 Set_Proper_Body (Unit (Subunit), New_Body); 7456 Set_Library_Unit (New_N, Subunit); 7457 Inherit_Context (Unit (Subunit), N); 7458 end; 7459 7460 -- If we are instantiating, this must be an error case, since 7461 -- otherwise we would have replaced the stub node by the proper body 7462 -- that corresponds. So just ignore it in the copy (i.e. we have 7463 -- copied it, and that is good enough). 7464 7465 else 7466 null; 7467 end if; 7468 7469 <<Subunit_Not_Found>> null; 7470 7471 -- If the node is a compilation unit, it is the subunit of a stub, which 7472 -- has been loaded already (see code below). In this case, the library 7473 -- unit field of N points to the parent unit (which is a compilation 7474 -- unit) and need not (and cannot) be copied. 7475 7476 -- When the proper body of the stub is analyzed, the library_unit link 7477 -- is used to establish the proper context (see sem_ch10). 7478 7479 -- The other fields of a compilation unit are copied as usual 7480 7481 elsif Nkind (N) = N_Compilation_Unit then 7482 7483 -- This code can only be executed when not instantiating, because in 7484 -- the copy made for an instantiation, the compilation unit node has 7485 -- disappeared at the point that a stub is replaced by its proper 7486 -- body. 7487 7488 pragma Assert (not Instantiating); 7489 7490 Set_Context_Items (New_N, 7491 Copy_Generic_List (Context_Items (N), New_N)); 7492 7493 Set_Unit (New_N, 7494 Copy_Generic_Node (Unit (N), New_N, False)); 7495 7496 Set_First_Inlined_Subprogram (New_N, 7497 Copy_Generic_Node 7498 (First_Inlined_Subprogram (N), New_N, False)); 7499 7500 Set_Aux_Decls_Node (New_N, 7501 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False)); 7502 7503 -- For an assignment node, the assignment is known to be semantically 7504 -- legal if we are instantiating the template. This avoids incorrect 7505 -- diagnostics in generated code. 7506 7507 elsif Nkind (N) = N_Assignment_Statement then 7508 7509 -- Copy name and expression fields in usual manner 7510 7511 Set_Name (New_N, 7512 Copy_Generic_Node (Name (N), New_N, Instantiating)); 7513 7514 Set_Expression (New_N, 7515 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 7516 7517 if Instantiating then 7518 Set_Assignment_OK (Name (New_N), True); 7519 end if; 7520 7521 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 7522 if not Instantiating then 7523 Set_Associated_Node (N, New_N); 7524 7525 else 7526 if Present (Get_Associated_Node (N)) 7527 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 7528 then 7529 -- In the generic the aggregate has some composite type. If at 7530 -- the point of instantiation the type has a private view, 7531 -- install the full view (and that of its ancestors, if any). 7532 7533 declare 7534 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 7535 Rt : Entity_Id; 7536 7537 begin 7538 if Present (T) and then Is_Private_Type (T) then 7539 Switch_View (T); 7540 end if; 7541 7542 if Present (T) 7543 and then Is_Tagged_Type (T) 7544 and then Is_Derived_Type (T) 7545 then 7546 Rt := Root_Type (T); 7547 7548 loop 7549 T := Etype (T); 7550 7551 if Is_Private_Type (T) then 7552 Switch_View (T); 7553 end if; 7554 7555 exit when T = Rt; 7556 end loop; 7557 end if; 7558 end; 7559 end if; 7560 end if; 7561 7562 -- Do not copy the associated node, which points to the generic copy 7563 -- of the aggregate. 7564 7565 declare 7566 use Atree.Unchecked_Access; 7567 -- This code section is part of the implementation of an untyped 7568 -- tree traversal, so it needs direct access to node fields. 7569 7570 begin 7571 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 7572 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 7573 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 7574 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 7575 end; 7576 7577 -- Allocators do not have an identifier denoting the access type, so we 7578 -- must locate it through the expression to check whether the views are 7579 -- consistent. 7580 7581 elsif Nkind (N) = N_Allocator 7582 and then Nkind (Expression (N)) = N_Qualified_Expression 7583 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 7584 and then Instantiating 7585 then 7586 declare 7587 T : constant Node_Id := 7588 Get_Associated_Node (Subtype_Mark (Expression (N))); 7589 Acc_T : Entity_Id; 7590 7591 begin 7592 if Present (T) then 7593 7594 -- Retrieve the allocator node in the generic copy 7595 7596 Acc_T := Etype (Parent (Parent (T))); 7597 7598 if Present (Acc_T) and then Is_Private_Type (Acc_T) then 7599 Switch_View (Acc_T); 7600 end if; 7601 end if; 7602 7603 Copy_Descendants; 7604 end; 7605 7606 -- For a proper body, we must catch the case of a proper body that 7607 -- replaces a stub. This represents the point at which a separate 7608 -- compilation unit, and hence template file, may be referenced, so we 7609 -- must make a new source instantiation entry for the template of the 7610 -- subunit, and ensure that all nodes in the subunit are adjusted using 7611 -- this new source instantiation entry. 7612 7613 elsif Nkind (N) in N_Proper_Body then 7614 declare 7615 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 7616 7617 begin 7618 if Instantiating and then Was_Originally_Stub (N) then 7619 Create_Instantiation_Source 7620 (Instantiation_Node, 7621 Defining_Entity (N), 7622 False, 7623 S_Adjustment); 7624 end if; 7625 7626 -- Now copy the fields of the proper body, using the new 7627 -- adjustment factor if one was needed as per test above. 7628 7629 Copy_Descendants; 7630 7631 -- Restore the original adjustment factor in case changed 7632 7633 S_Adjustment := Save_Adjustment; 7634 end; 7635 7636 elsif Nkind (N) = N_Pragma and then Instantiating then 7637 7638 -- Do not copy Comment or Ident pragmas their content is relevant to 7639 -- the generic unit, not to the instantiating unit. 7640 7641 if Nam_In (Pragma_Name (N), Name_Comment, Name_Ident) then 7642 New_N := Make_Null_Statement (Sloc (N)); 7643 7644 -- Do not copy pragmas generated from aspects because the pragmas do 7645 -- not carry any semantic information, plus they will be regenerated 7646 -- in the instance. 7647 7648 elsif From_Aspect_Specification (N) then 7649 New_N := Make_Null_Statement (Sloc (N)); 7650 7651 else 7652 Copy_Descendants; 7653 end if; 7654 7655 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 7656 7657 -- No descendant fields need traversing 7658 7659 null; 7660 7661 elsif Nkind (N) = N_String_Literal 7662 and then Present (Etype (N)) 7663 and then Instantiating 7664 then 7665 -- If the string is declared in an outer scope, the string_literal 7666 -- subtype created for it may have the wrong scope. Force reanalysis 7667 -- of the constant to generate a new itype in the proper context. 7668 7669 Set_Etype (New_N, Empty); 7670 Set_Analyzed (New_N, False); 7671 7672 -- For the remaining nodes, copy their descendants recursively 7673 7674 else 7675 Copy_Descendants; 7676 7677 if Instantiating and then Nkind (N) = N_Subprogram_Body then 7678 Set_Generic_Parent (Specification (New_N), N); 7679 7680 -- Should preserve Corresponding_Spec??? (12.3(14)) 7681 end if; 7682 end if; 7683 7684 return New_N; 7685 end Copy_Generic_Node; 7686 7687 ---------------------------- 7688 -- Denotes_Formal_Package -- 7689 ---------------------------- 7690 7691 function Denotes_Formal_Package 7692 (Pack : Entity_Id; 7693 On_Exit : Boolean := False; 7694 Instance : Entity_Id := Empty) return Boolean 7695 is 7696 Par : Entity_Id; 7697 Scop : constant Entity_Id := Scope (Pack); 7698 E : Entity_Id; 7699 7700 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 7701 -- The package in question may be an actual for a previous formal 7702 -- package P of the current instance, so examine its actuals as well. 7703 -- This must be recursive over other formal packages. 7704 7705 ---------------------------------- 7706 -- Is_Actual_Of_Previous_Formal -- 7707 ---------------------------------- 7708 7709 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 7710 E1 : Entity_Id; 7711 7712 begin 7713 E1 := First_Entity (P); 7714 while Present (E1) and then E1 /= Instance loop 7715 if Ekind (E1) = E_Package 7716 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 7717 then 7718 if Renamed_Object (E1) = Pack then 7719 return True; 7720 7721 elsif E1 = P or else Renamed_Object (E1) = P then 7722 return False; 7723 7724 elsif Is_Actual_Of_Previous_Formal (E1) then 7725 return True; 7726 end if; 7727 end if; 7728 7729 Next_Entity (E1); 7730 end loop; 7731 7732 return False; 7733 end Is_Actual_Of_Previous_Formal; 7734 7735 -- Start of processing for Denotes_Formal_Package 7736 7737 begin 7738 if On_Exit then 7739 Par := 7740 Instance_Envs.Table 7741 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 7742 else 7743 Par := Current_Instantiated_Parent.Act_Id; 7744 end if; 7745 7746 if Ekind (Scop) = E_Generic_Package 7747 or else Nkind (Unit_Declaration_Node (Scop)) = 7748 N_Generic_Subprogram_Declaration 7749 then 7750 return True; 7751 7752 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 7753 N_Formal_Package_Declaration 7754 then 7755 return True; 7756 7757 elsif No (Par) then 7758 return False; 7759 7760 else 7761 -- Check whether this package is associated with a formal package of 7762 -- the enclosing instantiation. Iterate over the list of renamings. 7763 7764 E := First_Entity (Par); 7765 while Present (E) loop 7766 if Ekind (E) /= E_Package 7767 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 7768 then 7769 null; 7770 7771 elsif Renamed_Object (E) = Par then 7772 return False; 7773 7774 elsif Renamed_Object (E) = Pack then 7775 return True; 7776 7777 elsif Is_Actual_Of_Previous_Formal (E) then 7778 return True; 7779 7780 end if; 7781 7782 Next_Entity (E); 7783 end loop; 7784 7785 return False; 7786 end if; 7787 end Denotes_Formal_Package; 7788 7789 ----------------- 7790 -- End_Generic -- 7791 ----------------- 7792 7793 procedure End_Generic is 7794 begin 7795 -- ??? More things could be factored out in this routine. Should 7796 -- probably be done at a later stage. 7797 7798 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 7799 Generic_Flags.Decrement_Last; 7800 7801 Expander_Mode_Restore; 7802 end End_Generic; 7803 7804 ------------- 7805 -- Earlier -- 7806 ------------- 7807 7808 function Earlier (N1, N2 : Node_Id) return Boolean is 7809 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 7810 -- Find distance from given node to enclosing compilation unit 7811 7812 ---------------- 7813 -- Find_Depth -- 7814 ---------------- 7815 7816 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 7817 begin 7818 while Present (P) 7819 and then Nkind (P) /= N_Compilation_Unit 7820 loop 7821 P := True_Parent (P); 7822 D := D + 1; 7823 end loop; 7824 end Find_Depth; 7825 7826 -- Local declarations 7827 7828 D1 : Integer := 0; 7829 D2 : Integer := 0; 7830 P1 : Node_Id := N1; 7831 P2 : Node_Id := N2; 7832 T1 : Source_Ptr; 7833 T2 : Source_Ptr; 7834 7835 -- Start of processing for Earlier 7836 7837 begin 7838 Find_Depth (P1, D1); 7839 Find_Depth (P2, D2); 7840 7841 if P1 /= P2 then 7842 return False; 7843 else 7844 P1 := N1; 7845 P2 := N2; 7846 end if; 7847 7848 while D1 > D2 loop 7849 P1 := True_Parent (P1); 7850 D1 := D1 - 1; 7851 end loop; 7852 7853 while D2 > D1 loop 7854 P2 := True_Parent (P2); 7855 D2 := D2 - 1; 7856 end loop; 7857 7858 -- At this point P1 and P2 are at the same distance from the root. 7859 -- We examine their parents until we find a common declarative list. 7860 -- If we reach the root, N1 and N2 do not descend from the same 7861 -- declarative list (e.g. one is nested in the declarative part and 7862 -- the other is in a block in the statement part) and the earlier 7863 -- one is already frozen. 7864 7865 while not Is_List_Member (P1) 7866 or else not Is_List_Member (P2) 7867 or else List_Containing (P1) /= List_Containing (P2) 7868 loop 7869 P1 := True_Parent (P1); 7870 P2 := True_Parent (P2); 7871 7872 if Nkind (Parent (P1)) = N_Subunit then 7873 P1 := Corresponding_Stub (Parent (P1)); 7874 end if; 7875 7876 if Nkind (Parent (P2)) = N_Subunit then 7877 P2 := Corresponding_Stub (Parent (P2)); 7878 end if; 7879 7880 if P1 = P2 then 7881 return False; 7882 end if; 7883 end loop; 7884 7885 -- Expanded code usually shares the source location of the original 7886 -- construct it was generated for. This however may not necessarely 7887 -- reflect the true location of the code within the tree. 7888 7889 -- Before comparing the slocs of the two nodes, make sure that we are 7890 -- working with correct source locations. Assume that P1 is to the left 7891 -- of P2. If either one does not come from source, traverse the common 7892 -- list heading towards the other node and locate the first source 7893 -- statement. 7894 7895 -- P1 P2 7896 -- ----+===+===+--------------+===+===+---- 7897 -- expanded code expanded code 7898 7899 if not Comes_From_Source (P1) then 7900 while Present (P1) loop 7901 7902 -- Neither P2 nor a source statement were located during the 7903 -- search. If we reach the end of the list, then P1 does not 7904 -- occur earlier than P2. 7905 7906 -- ----> 7907 -- start --- P2 ----- P1 --- end 7908 7909 if No (Next (P1)) then 7910 return False; 7911 7912 -- We encounter P2 while going to the right of the list. This 7913 -- means that P1 does indeed appear earlier. 7914 7915 -- ----> 7916 -- start --- P1 ===== P2 --- end 7917 -- expanded code in between 7918 7919 elsif P1 = P2 then 7920 return True; 7921 7922 -- No need to look any further since we have located a source 7923 -- statement. 7924 7925 elsif Comes_From_Source (P1) then 7926 exit; 7927 end if; 7928 7929 -- Keep going right 7930 7931 Next (P1); 7932 end loop; 7933 end if; 7934 7935 if not Comes_From_Source (P2) then 7936 while Present (P2) loop 7937 7938 -- Neither P1 nor a source statement were located during the 7939 -- search. If we reach the start of the list, then P1 does not 7940 -- occur earlier than P2. 7941 7942 -- <---- 7943 -- start --- P2 --- P1 --- end 7944 7945 if No (Prev (P2)) then 7946 return False; 7947 7948 -- We encounter P1 while going to the left of the list. This 7949 -- means that P1 does indeed appear earlier. 7950 7951 -- <---- 7952 -- start --- P1 ===== P2 --- end 7953 -- expanded code in between 7954 7955 elsif P2 = P1 then 7956 return True; 7957 7958 -- No need to look any further since we have located a source 7959 -- statement. 7960 7961 elsif Comes_From_Source (P2) then 7962 exit; 7963 end if; 7964 7965 -- Keep going left 7966 7967 Prev (P2); 7968 end loop; 7969 end if; 7970 7971 -- At this point either both nodes came from source or we approximated 7972 -- their source locations through neighboring source statements. 7973 7974 T1 := Top_Level_Location (Sloc (P1)); 7975 T2 := Top_Level_Location (Sloc (P2)); 7976 7977 -- When two nodes come from the same instance, they have identical top 7978 -- level locations. To determine proper relation within the tree, check 7979 -- their locations within the template. 7980 7981 if T1 = T2 then 7982 return Sloc (P1) < Sloc (P2); 7983 7984 -- The two nodes either come from unrelated instances or do not come 7985 -- from instantiated code at all. 7986 7987 else 7988 return T1 < T2; 7989 end if; 7990 end Earlier; 7991 7992 ---------------------- 7993 -- Find_Actual_Type -- 7994 ---------------------- 7995 7996 function Find_Actual_Type 7997 (Typ : Entity_Id; 7998 Gen_Type : Entity_Id) return Entity_Id 7999 is 8000 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 8001 T : Entity_Id; 8002 8003 begin 8004 -- Special processing only applies to child units 8005 8006 if not Is_Child_Unit (Gen_Scope) then 8007 return Get_Instance_Of (Typ); 8008 8009 -- If designated or component type is itself a formal of the child unit, 8010 -- its instance is available. 8011 8012 elsif Scope (Typ) = Gen_Scope then 8013 return Get_Instance_Of (Typ); 8014 8015 -- If the array or access type is not declared in the parent unit, 8016 -- no special processing needed. 8017 8018 elsif not Is_Generic_Type (Typ) 8019 and then Scope (Gen_Scope) /= Scope (Typ) 8020 then 8021 return Get_Instance_Of (Typ); 8022 8023 -- Otherwise, retrieve designated or component type by visibility 8024 8025 else 8026 T := Current_Entity (Typ); 8027 while Present (T) loop 8028 if In_Open_Scopes (Scope (T)) then 8029 return T; 8030 elsif Is_Generic_Actual_Type (T) then 8031 return T; 8032 end if; 8033 8034 T := Homonym (T); 8035 end loop; 8036 8037 return Typ; 8038 end if; 8039 end Find_Actual_Type; 8040 8041 ---------------------------- 8042 -- Freeze_Subprogram_Body -- 8043 ---------------------------- 8044 8045 procedure Freeze_Subprogram_Body 8046 (Inst_Node : Node_Id; 8047 Gen_Body : Node_Id; 8048 Pack_Id : Entity_Id) 8049 is 8050 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 8051 Par : constant Entity_Id := Scope (Gen_Unit); 8052 E_G_Id : Entity_Id; 8053 Enc_G : Entity_Id; 8054 Enc_I : Node_Id; 8055 F_Node : Node_Id; 8056 8057 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 8058 -- Find innermost package body that encloses the given node, and which 8059 -- is not a compilation unit. Freeze nodes for the instance, or for its 8060 -- enclosing body, may be inserted after the enclosing_body of the 8061 -- generic unit. Used to determine proper placement of freeze node for 8062 -- both package and subprogram instances. 8063 8064 function Package_Freeze_Node (B : Node_Id) return Node_Id; 8065 -- Find entity for given package body, and locate or create a freeze 8066 -- node for it. 8067 8068 ---------------------------- 8069 -- Enclosing_Package_Body -- 8070 ---------------------------- 8071 8072 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 8073 P : Node_Id; 8074 8075 begin 8076 P := Parent (N); 8077 while Present (P) 8078 and then Nkind (Parent (P)) /= N_Compilation_Unit 8079 loop 8080 if Nkind (P) = N_Package_Body then 8081 if Nkind (Parent (P)) = N_Subunit then 8082 return Corresponding_Stub (Parent (P)); 8083 else 8084 return P; 8085 end if; 8086 end if; 8087 8088 P := True_Parent (P); 8089 end loop; 8090 8091 return Empty; 8092 end Enclosing_Package_Body; 8093 8094 ------------------------- 8095 -- Package_Freeze_Node -- 8096 ------------------------- 8097 8098 function Package_Freeze_Node (B : Node_Id) return Node_Id is 8099 Id : Entity_Id; 8100 8101 begin 8102 if Nkind (B) = N_Package_Body then 8103 Id := Corresponding_Spec (B); 8104 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 8105 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 8106 end if; 8107 8108 Ensure_Freeze_Node (Id); 8109 return Freeze_Node (Id); 8110 end Package_Freeze_Node; 8111 8112 -- Start of processing for Freeze_Subprogram_Body 8113 8114 begin 8115 -- If the instance and the generic body appear within the same unit, and 8116 -- the instance precedes the generic, the freeze node for the instance 8117 -- must appear after that of the generic. If the generic is nested 8118 -- within another instance I2, then current instance must be frozen 8119 -- after I2. In both cases, the freeze nodes are those of enclosing 8120 -- packages. Otherwise, the freeze node is placed at the end of the 8121 -- current declarative part. 8122 8123 Enc_G := Enclosing_Package_Body (Gen_Body); 8124 Enc_I := Enclosing_Package_Body (Inst_Node); 8125 Ensure_Freeze_Node (Pack_Id); 8126 F_Node := Freeze_Node (Pack_Id); 8127 8128 if Is_Generic_Instance (Par) 8129 and then Present (Freeze_Node (Par)) 8130 and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) 8131 then 8132 -- The parent was a premature instantiation. Insert freeze node at 8133 -- the end the current declarative part. 8134 8135 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then 8136 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8137 8138 -- Handle the following case: 8139 -- 8140 -- package Parent_Inst is new ... 8141 -- Parent_Inst [] 8142 -- 8143 -- procedure P ... -- this body freezes Parent_Inst 8144 -- 8145 -- package Inst is new ... 8146 -- 8147 -- In this particular scenario, the freeze node for Inst must be 8148 -- inserted in the same manner as that of Parent_Inst - before the 8149 -- next source body or at the end of the declarative list (body not 8150 -- available). If body P did not exist and Parent_Inst was frozen 8151 -- after Inst, either by a body following Inst or at the end of the 8152 -- declarative region, the freeze node for Inst must be inserted 8153 -- after that of Parent_Inst. This relation is established by 8154 -- comparing the Slocs of Parent_Inst freeze node and Inst. 8155 8156 elsif List_Containing (Get_Package_Instantiation_Node (Par)) = 8157 List_Containing (Inst_Node) 8158 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 8159 then 8160 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8161 8162 else 8163 Insert_After (Freeze_Node (Par), F_Node); 8164 end if; 8165 8166 -- The body enclosing the instance should be frozen after the body that 8167 -- includes the generic, because the body of the instance may make 8168 -- references to entities therein. If the two are not in the same 8169 -- declarative part, or if the one enclosing the instance is frozen 8170 -- already, freeze the instance at the end of the current declarative 8171 -- part. 8172 8173 elsif Is_Generic_Instance (Par) 8174 and then Present (Freeze_Node (Par)) 8175 and then Present (Enc_I) 8176 then 8177 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) 8178 or else 8179 (Nkind (Enc_I) = N_Package_Body 8180 and then 8181 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) 8182 then 8183 -- The enclosing package may contain several instances. Rather 8184 -- than computing the earliest point at which to insert its freeze 8185 -- node, we place it at the end of the declarative part of the 8186 -- parent of the generic. 8187 8188 Insert_Freeze_Node_For_Instance 8189 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 8190 end if; 8191 8192 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8193 8194 elsif Present (Enc_G) 8195 and then Present (Enc_I) 8196 and then Enc_G /= Enc_I 8197 and then Earlier (Inst_Node, Gen_Body) 8198 then 8199 if Nkind (Enc_G) = N_Package_Body then 8200 E_G_Id := 8201 Corresponding_Spec (Enc_G); 8202 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 8203 E_G_Id := 8204 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 8205 end if; 8206 8207 -- Freeze package that encloses instance, and place node after the 8208 -- package that encloses generic. If enclosing package is already 8209 -- frozen we have to assume it is at the proper place. This may be a 8210 -- potential ABE that requires dynamic checking. Do not add a freeze 8211 -- node if the package that encloses the generic is inside the body 8212 -- that encloses the instance, because the freeze node would be in 8213 -- the wrong scope. Additional contortions needed if the bodies are 8214 -- within a subunit. 8215 8216 declare 8217 Enclosing_Body : Node_Id; 8218 8219 begin 8220 if Nkind (Enc_I) = N_Package_Body_Stub then 8221 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 8222 else 8223 Enclosing_Body := Enc_I; 8224 end if; 8225 8226 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 8227 Insert_Freeze_Node_For_Instance 8228 (Enc_G, Package_Freeze_Node (Enc_I)); 8229 end if; 8230 end; 8231 8232 -- Freeze enclosing subunit before instance 8233 8234 Ensure_Freeze_Node (E_G_Id); 8235 8236 if not Is_List_Member (Freeze_Node (E_G_Id)) then 8237 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 8238 end if; 8239 8240 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8241 8242 else 8243 -- If none of the above, insert freeze node at the end of the current 8244 -- declarative part. 8245 8246 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8247 end if; 8248 end Freeze_Subprogram_Body; 8249 8250 ---------------- 8251 -- Get_Gen_Id -- 8252 ---------------- 8253 8254 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 8255 begin 8256 return Generic_Renamings.Table (E).Gen_Id; 8257 end Get_Gen_Id; 8258 8259 --------------------- 8260 -- Get_Instance_Of -- 8261 --------------------- 8262 8263 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 8264 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 8265 8266 begin 8267 if Res /= Assoc_Null then 8268 return Generic_Renamings.Table (Res).Act_Id; 8269 8270 else 8271 -- On exit, entity is not instantiated: not a generic parameter, or 8272 -- else parameter of an inner generic unit. 8273 8274 return A; 8275 end if; 8276 end Get_Instance_Of; 8277 8278 ------------------------------------ 8279 -- Get_Package_Instantiation_Node -- 8280 ------------------------------------ 8281 8282 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is 8283 Decl : Node_Id := Unit_Declaration_Node (A); 8284 Inst : Node_Id; 8285 8286 begin 8287 -- If the Package_Instantiation attribute has been set on the package 8288 -- entity, then use it directly when it (or its Original_Node) refers 8289 -- to an N_Package_Instantiation node. In principle it should be 8290 -- possible to have this field set in all cases, which should be 8291 -- investigated, and would allow this function to be significantly 8292 -- simplified. ??? 8293 8294 Inst := Package_Instantiation (A); 8295 8296 if Present (Inst) then 8297 if Nkind (Inst) = N_Package_Instantiation then 8298 return Inst; 8299 8300 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 8301 return Original_Node (Inst); 8302 end if; 8303 end if; 8304 8305 -- If the instantiation is a compilation unit that does not need body 8306 -- then the instantiation node has been rewritten as a package 8307 -- declaration for the instance, and we return the original node. 8308 8309 -- If it is a compilation unit and the instance node has not been 8310 -- rewritten, then it is still the unit of the compilation. Finally, if 8311 -- a body is present, this is a parent of the main unit whose body has 8312 -- been compiled for inlining purposes, and the instantiation node has 8313 -- been rewritten with the instance body. 8314 8315 -- Otherwise the instantiation node appears after the declaration. If 8316 -- the entity is a formal package, the declaration may have been 8317 -- rewritten as a generic declaration (in the case of a formal with box) 8318 -- or left as a formal package declaration if it has actuals, and is 8319 -- found with a forward search. 8320 8321 if Nkind (Parent (Decl)) = N_Compilation_Unit then 8322 if Nkind (Decl) = N_Package_Declaration 8323 and then Present (Corresponding_Body (Decl)) 8324 then 8325 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 8326 end if; 8327 8328 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then 8329 return Original_Node (Decl); 8330 else 8331 return Unit (Parent (Decl)); 8332 end if; 8333 8334 elsif Nkind (Decl) = N_Package_Declaration 8335 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 8336 then 8337 return Original_Node (Decl); 8338 8339 else 8340 Inst := Next (Decl); 8341 while not Nkind_In (Inst, N_Package_Instantiation, 8342 N_Formal_Package_Declaration) 8343 loop 8344 Next (Inst); 8345 end loop; 8346 8347 return Inst; 8348 end if; 8349 end Get_Package_Instantiation_Node; 8350 8351 ------------------------ 8352 -- Has_Been_Exchanged -- 8353 ------------------------ 8354 8355 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 8356 Next : Elmt_Id; 8357 8358 begin 8359 Next := First_Elmt (Exchanged_Views); 8360 while Present (Next) loop 8361 if Full_View (Node (Next)) = E then 8362 return True; 8363 end if; 8364 8365 Next_Elmt (Next); 8366 end loop; 8367 8368 return False; 8369 end Has_Been_Exchanged; 8370 8371 ---------- 8372 -- Hash -- 8373 ---------- 8374 8375 function Hash (F : Entity_Id) return HTable_Range is 8376 begin 8377 return HTable_Range (F mod HTable_Size); 8378 end Hash; 8379 8380 ------------------------ 8381 -- Hide_Current_Scope -- 8382 ------------------------ 8383 8384 procedure Hide_Current_Scope is 8385 C : constant Entity_Id := Current_Scope; 8386 E : Entity_Id; 8387 8388 begin 8389 Set_Is_Hidden_Open_Scope (C); 8390 8391 E := First_Entity (C); 8392 while Present (E) loop 8393 if Is_Immediately_Visible (E) then 8394 Set_Is_Immediately_Visible (E, False); 8395 Append_Elmt (E, Hidden_Entities); 8396 end if; 8397 8398 Next_Entity (E); 8399 end loop; 8400 8401 -- Make the scope name invisible as well. This is necessary, but might 8402 -- conflict with calls to Rtsfind later on, in case the scope is a 8403 -- predefined one. There is no clean solution to this problem, so for 8404 -- now we depend on the user not redefining Standard itself in one of 8405 -- the parent units. 8406 8407 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 8408 Set_Is_Immediately_Visible (C, False); 8409 Append_Elmt (C, Hidden_Entities); 8410 end if; 8411 8412 end Hide_Current_Scope; 8413 8414 -------------- 8415 -- Init_Env -- 8416 -------------- 8417 8418 procedure Init_Env is 8419 Saved : Instance_Env; 8420 8421 begin 8422 Saved.Instantiated_Parent := Current_Instantiated_Parent; 8423 Saved.Exchanged_Views := Exchanged_Views; 8424 Saved.Hidden_Entities := Hidden_Entities; 8425 Saved.Current_Sem_Unit := Current_Sem_Unit; 8426 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 8427 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 8428 8429 -- Save configuration switches. These may be reset if the unit is a 8430 -- predefined unit, and the current mode is not Ada 2005. 8431 8432 Save_Opt_Config_Switches (Saved.Switches); 8433 8434 Instance_Envs.Append (Saved); 8435 8436 Exchanged_Views := New_Elmt_List; 8437 Hidden_Entities := New_Elmt_List; 8438 8439 -- Make dummy entry for Instantiated parent. If generic unit is legal, 8440 -- this is set properly in Set_Instance_Env. 8441 8442 Current_Instantiated_Parent := 8443 (Current_Scope, Current_Scope, Assoc_Null); 8444 end Init_Env; 8445 8446 ------------------------------ 8447 -- In_Same_Declarative_Part -- 8448 ------------------------------ 8449 8450 function In_Same_Declarative_Part 8451 (F_Node : Node_Id; 8452 Inst : Node_Id) return Boolean 8453 is 8454 Decls : constant Node_Id := Parent (F_Node); 8455 Nod : Node_Id; 8456 8457 begin 8458 Nod := Parent (Inst); 8459 while Present (Nod) loop 8460 if Nod = Decls then 8461 return True; 8462 8463 elsif Nkind_In (Nod, N_Subprogram_Body, 8464 N_Package_Body, 8465 N_Package_Declaration, 8466 N_Task_Body, 8467 N_Protected_Body, 8468 N_Block_Statement) 8469 then 8470 return False; 8471 8472 elsif Nkind (Nod) = N_Subunit then 8473 Nod := Corresponding_Stub (Nod); 8474 8475 elsif Nkind (Nod) = N_Compilation_Unit then 8476 return False; 8477 8478 else 8479 Nod := Parent (Nod); 8480 end if; 8481 end loop; 8482 8483 return False; 8484 end In_Same_Declarative_Part; 8485 8486 --------------------- 8487 -- In_Main_Context -- 8488 --------------------- 8489 8490 function In_Main_Context (E : Entity_Id) return Boolean is 8491 Context : List_Id; 8492 Clause : Node_Id; 8493 Nam : Node_Id; 8494 8495 begin 8496 if not Is_Compilation_Unit (E) 8497 or else Ekind (E) /= E_Package 8498 or else In_Private_Part (E) 8499 then 8500 return False; 8501 end if; 8502 8503 Context := Context_Items (Cunit (Main_Unit)); 8504 8505 Clause := First (Context); 8506 while Present (Clause) loop 8507 if Nkind (Clause) = N_With_Clause then 8508 Nam := Name (Clause); 8509 8510 -- If the current scope is part of the context of the main unit, 8511 -- analysis of the corresponding with_clause is not complete, and 8512 -- the entity is not set. We use the Chars field directly, which 8513 -- might produce false positives in rare cases, but guarantees 8514 -- that we produce all the instance bodies we will need. 8515 8516 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 8517 or else (Nkind (Nam) = N_Selected_Component 8518 and then Chars (Selector_Name (Nam)) = Chars (E)) 8519 then 8520 return True; 8521 end if; 8522 end if; 8523 8524 Next (Clause); 8525 end loop; 8526 8527 return False; 8528 end In_Main_Context; 8529 8530 --------------------- 8531 -- Inherit_Context -- 8532 --------------------- 8533 8534 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 8535 Current_Context : List_Id; 8536 Current_Unit : Node_Id; 8537 Item : Node_Id; 8538 New_I : Node_Id; 8539 8540 Clause : Node_Id; 8541 OK : Boolean; 8542 Lib_Unit : Node_Id; 8543 8544 begin 8545 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 8546 8547 -- The inherited context is attached to the enclosing compilation 8548 -- unit. This is either the main unit, or the declaration for the 8549 -- main unit (in case the instantiation appears within the package 8550 -- declaration and the main unit is its body). 8551 8552 Current_Unit := Parent (Inst); 8553 while Present (Current_Unit) 8554 and then Nkind (Current_Unit) /= N_Compilation_Unit 8555 loop 8556 Current_Unit := Parent (Current_Unit); 8557 end loop; 8558 8559 Current_Context := Context_Items (Current_Unit); 8560 8561 Item := First (Context_Items (Parent (Gen_Decl))); 8562 while Present (Item) loop 8563 if Nkind (Item) = N_With_Clause then 8564 Lib_Unit := Library_Unit (Item); 8565 8566 -- Take care to prevent direct cyclic with's 8567 8568 if Lib_Unit /= Current_Unit then 8569 8570 -- Do not add a unit if it is already in the context 8571 8572 Clause := First (Current_Context); 8573 OK := True; 8574 while Present (Clause) loop 8575 if Nkind (Clause) = N_With_Clause and then 8576 Library_Unit (Clause) = Lib_Unit 8577 then 8578 OK := False; 8579 exit; 8580 end if; 8581 8582 Next (Clause); 8583 end loop; 8584 8585 if OK then 8586 New_I := New_Copy (Item); 8587 Set_Implicit_With (New_I, True); 8588 Set_Implicit_With_From_Instantiation (New_I, True); 8589 Append (New_I, Current_Context); 8590 end if; 8591 end if; 8592 end if; 8593 8594 Next (Item); 8595 end loop; 8596 end if; 8597 end Inherit_Context; 8598 8599 ---------------- 8600 -- Initialize -- 8601 ---------------- 8602 8603 procedure Initialize is 8604 begin 8605 Generic_Renamings.Init; 8606 Instance_Envs.Init; 8607 Generic_Flags.Init; 8608 Generic_Renamings_HTable.Reset; 8609 Circularity_Detected := False; 8610 Exchanged_Views := No_Elist; 8611 Hidden_Entities := No_Elist; 8612 end Initialize; 8613 8614 ------------------------------------- 8615 -- Insert_Freeze_Node_For_Instance -- 8616 ------------------------------------- 8617 8618 procedure Insert_Freeze_Node_For_Instance 8619 (N : Node_Id; 8620 F_Node : Node_Id) 8621 is 8622 Decl : Node_Id; 8623 Decls : List_Id; 8624 Inst : Entity_Id; 8625 Par_N : Node_Id; 8626 8627 function Enclosing_Body (N : Node_Id) return Node_Id; 8628 -- Find enclosing package or subprogram body, if any. Freeze node may 8629 -- be placed at end of current declarative list if previous instance 8630 -- and current one have different enclosing bodies. 8631 8632 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 8633 -- Find the local instance, if any, that declares the generic that is 8634 -- being instantiated. If present, the freeze node for this instance 8635 -- must follow the freeze node for the previous instance. 8636 8637 -------------------- 8638 -- Enclosing_Body -- 8639 -------------------- 8640 8641 function Enclosing_Body (N : Node_Id) return Node_Id is 8642 P : Node_Id; 8643 8644 begin 8645 P := Parent (N); 8646 while Present (P) 8647 and then Nkind (Parent (P)) /= N_Compilation_Unit 8648 loop 8649 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 8650 if Nkind (Parent (P)) = N_Subunit then 8651 return Corresponding_Stub (Parent (P)); 8652 else 8653 return P; 8654 end if; 8655 end if; 8656 8657 P := True_Parent (P); 8658 end loop; 8659 8660 return Empty; 8661 end Enclosing_Body; 8662 8663 ----------------------- 8664 -- Previous_Instance -- 8665 ----------------------- 8666 8667 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 8668 S : Entity_Id; 8669 8670 begin 8671 S := Scope (Gen); 8672 while Present (S) and then S /= Standard_Standard loop 8673 if Is_Generic_Instance (S) 8674 and then In_Same_Source_Unit (S, N) 8675 then 8676 return S; 8677 end if; 8678 8679 S := Scope (S); 8680 end loop; 8681 8682 return Empty; 8683 end Previous_Instance; 8684 8685 -- Start of processing for Insert_Freeze_Node_For_Instance 8686 8687 begin 8688 if not Is_List_Member (F_Node) then 8689 Decl := N; 8690 Decls := List_Containing (N); 8691 Inst := Entity (F_Node); 8692 Par_N := Parent (Decls); 8693 8694 -- When processing a subprogram instantiation, utilize the actual 8695 -- subprogram instantiation rather than its package wrapper as it 8696 -- carries all the context information. 8697 8698 if Is_Wrapper_Package (Inst) then 8699 Inst := Related_Instance (Inst); 8700 end if; 8701 8702 -- If this is a package instance, check whether the generic is 8703 -- declared in a previous instance and the current instance is 8704 -- not within the previous one. 8705 8706 if Present (Generic_Parent (Parent (Inst))) 8707 and then Is_In_Main_Unit (N) 8708 then 8709 declare 8710 Enclosing_N : constant Node_Id := Enclosing_Body (N); 8711 Par_I : constant Entity_Id := 8712 Previous_Instance 8713 (Generic_Parent (Parent (Inst))); 8714 Scop : Entity_Id; 8715 8716 begin 8717 if Present (Par_I) 8718 and then Earlier (N, Freeze_Node (Par_I)) 8719 then 8720 Scop := Scope (Inst); 8721 8722 -- If the current instance is within the one that contains 8723 -- the generic, the freeze node for the current one must 8724 -- appear in the current declarative part. Ditto, if the 8725 -- current instance is within another package instance or 8726 -- within a body that does not enclose the current instance. 8727 -- In these three cases the freeze node of the previous 8728 -- instance is not relevant. 8729 8730 while Present (Scop) and then Scop /= Standard_Standard loop 8731 exit when Scop = Par_I 8732 or else 8733 (Is_Generic_Instance (Scop) 8734 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 8735 Scop := Scope (Scop); 8736 end loop; 8737 8738 -- Previous instance encloses current instance 8739 8740 if Scop = Par_I then 8741 null; 8742 8743 -- If the next node is a source body we must freeze in 8744 -- the current scope as well. 8745 8746 elsif Present (Next (N)) 8747 and then Nkind_In (Next (N), N_Subprogram_Body, 8748 N_Package_Body) 8749 and then Comes_From_Source (Next (N)) 8750 then 8751 null; 8752 8753 -- Current instance is within an unrelated instance 8754 8755 elsif Is_Generic_Instance (Scop) then 8756 null; 8757 8758 -- Current instance is within an unrelated body 8759 8760 elsif Present (Enclosing_N) 8761 and then Enclosing_N /= Enclosing_Body (Par_I) 8762 then 8763 null; 8764 8765 else 8766 Insert_After (Freeze_Node (Par_I), F_Node); 8767 return; 8768 end if; 8769 end if; 8770 end; 8771 end if; 8772 8773 -- When the instantiation occurs in a package declaration, append the 8774 -- freeze node to the private declarations (if any). 8775 8776 if Nkind (Par_N) = N_Package_Specification 8777 and then Decls = Visible_Declarations (Par_N) 8778 and then Present (Private_Declarations (Par_N)) 8779 and then not Is_Empty_List (Private_Declarations (Par_N)) 8780 then 8781 Decls := Private_Declarations (Par_N); 8782 Decl := First (Decls); 8783 end if; 8784 8785 -- Determine the proper freeze point of a package instantiation. We 8786 -- adhere to the general rule of a package or subprogram body causing 8787 -- freezing of anything before it in the same declarative region. In 8788 -- this case, the proper freeze point of a package instantiation is 8789 -- before the first source body which follows, or before a stub. This 8790 -- ensures that entities coming from the instance are already frozen 8791 -- and usable in source bodies. 8792 8793 if Nkind (Par_N) /= N_Package_Declaration 8794 and then Ekind (Inst) = E_Package 8795 and then Is_Generic_Instance (Inst) 8796 and then 8797 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 8798 then 8799 while Present (Decl) loop 8800 if (Nkind (Decl) in N_Unit_Body 8801 or else 8802 Nkind (Decl) in N_Body_Stub) 8803 and then Comes_From_Source (Decl) 8804 then 8805 Insert_Before (Decl, F_Node); 8806 return; 8807 end if; 8808 8809 Next (Decl); 8810 end loop; 8811 end if; 8812 8813 -- In a package declaration, or if no previous body, insert at end 8814 -- of list. 8815 8816 Set_Sloc (F_Node, Sloc (Last (Decls))); 8817 Insert_After (Last (Decls), F_Node); 8818 end if; 8819 end Insert_Freeze_Node_For_Instance; 8820 8821 ------------------ 8822 -- Install_Body -- 8823 ------------------ 8824 8825 procedure Install_Body 8826 (Act_Body : Node_Id; 8827 N : Node_Id; 8828 Gen_Body : Node_Id; 8829 Gen_Decl : Node_Id) 8830 is 8831 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 8832 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 8833 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 8834 Par : constant Entity_Id := Scope (Gen_Id); 8835 Gen_Unit : constant Node_Id := 8836 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 8837 Orig_Body : Node_Id := Gen_Body; 8838 F_Node : Node_Id; 8839 Body_Unit : Node_Id; 8840 8841 Must_Delay : Boolean; 8842 8843 function In_Same_Enclosing_Subp return Boolean; 8844 -- Check whether instance and generic body are within same subprogram. 8845 8846 function True_Sloc (N : Node_Id) return Source_Ptr; 8847 -- If the instance is nested inside a generic unit, the Sloc of the 8848 -- instance indicates the place of the original definition, not the 8849 -- point of the current enclosing instance. Pending a better usage of 8850 -- Slocs to indicate instantiation places, we determine the place of 8851 -- origin of a node by finding the maximum sloc of any ancestor node. 8852 -- Why is this not equivalent to Top_Level_Location ??? 8853 8854 ---------------------------- 8855 -- In_Same_Enclosing_Subp -- 8856 ---------------------------- 8857 8858 function In_Same_Enclosing_Subp return Boolean is 8859 Scop : Entity_Id; 8860 Subp : Entity_Id; 8861 8862 begin 8863 Scop := Scope (Act_Id); 8864 while Scop /= Standard_Standard 8865 and then not Is_Overloadable (Scop) 8866 loop 8867 Scop := Scope (Scop); 8868 end loop; 8869 8870 if Scop = Standard_Standard then 8871 return False; 8872 else 8873 Subp := Scop; 8874 end if; 8875 8876 Scop := Scope (Gen_Id); 8877 while Scop /= Standard_Standard loop 8878 if Scop = Subp then 8879 return True; 8880 else 8881 Scop := Scope (Scop); 8882 end if; 8883 end loop; 8884 8885 return False; 8886 end In_Same_Enclosing_Subp; 8887 8888 --------------- 8889 -- True_Sloc -- 8890 --------------- 8891 8892 function True_Sloc (N : Node_Id) return Source_Ptr is 8893 Res : Source_Ptr; 8894 N1 : Node_Id; 8895 8896 begin 8897 Res := Sloc (N); 8898 N1 := N; 8899 while Present (N1) and then N1 /= Act_Unit loop 8900 if Sloc (N1) > Res then 8901 Res := Sloc (N1); 8902 end if; 8903 8904 N1 := Parent (N1); 8905 end loop; 8906 8907 return Res; 8908 end True_Sloc; 8909 8910 -- Start of processing for Install_Body 8911 8912 begin 8913 -- Handle first the case of an instance with incomplete actual types. 8914 -- The instance body cannot be placed after the declaration because 8915 -- full views have not been seen yet. Any use of the non-limited views 8916 -- in the instance body requires the presence of a regular with_clause 8917 -- in the enclosing unit, and will fail if this with_clause is missing. 8918 -- We place the instance body at the beginning of the enclosing body, 8919 -- which is the unit being compiled. The freeze node for the instance 8920 -- is then placed after the instance body. 8921 8922 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) 8923 and then Expander_Active 8924 and then Ekind (Scope (Act_Id)) = E_Package 8925 then 8926 declare 8927 Scop : constant Entity_Id := Scope (Act_Id); 8928 Body_Id : constant Node_Id := 8929 Corresponding_Body (Unit_Declaration_Node (Scop)); 8930 8931 begin 8932 Ensure_Freeze_Node (Act_Id); 8933 F_Node := Freeze_Node (Act_Id); 8934 if Present (Body_Id) then 8935 Set_Is_Frozen (Act_Id, False); 8936 Prepend (Act_Body, Declarations (Parent (Body_Id))); 8937 if Is_List_Member (F_Node) then 8938 Remove (F_Node); 8939 end if; 8940 8941 Insert_After (Act_Body, F_Node); 8942 end if; 8943 end; 8944 return; 8945 end if; 8946 8947 -- If the body is a subunit, the freeze point is the corresponding stub 8948 -- in the current compilation, not the subunit itself. 8949 8950 if Nkind (Parent (Gen_Body)) = N_Subunit then 8951 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 8952 else 8953 Orig_Body := Gen_Body; 8954 end if; 8955 8956 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 8957 8958 -- If the instantiation and the generic definition appear in the same 8959 -- package declaration, this is an early instantiation. If they appear 8960 -- in the same declarative part, it is an early instantiation only if 8961 -- the generic body appears textually later, and the generic body is 8962 -- also in the main unit. 8963 8964 -- If instance is nested within a subprogram, and the generic body 8965 -- is not, the instance is delayed because the enclosing body is. If 8966 -- instance and body are within the same scope, or the same subprogram 8967 -- body, indicate explicitly that the instance is delayed. 8968 8969 Must_Delay := 8970 (Gen_Unit = Act_Unit 8971 and then (Nkind_In (Gen_Unit, N_Package_Declaration, 8972 N_Generic_Package_Declaration) 8973 or else (Gen_Unit = Body_Unit 8974 and then True_Sloc (N) < Sloc (Orig_Body))) 8975 and then Is_In_Main_Unit (Gen_Unit) 8976 and then (Scope (Act_Id) = Scope (Gen_Id) 8977 or else In_Same_Enclosing_Subp)); 8978 8979 -- If this is an early instantiation, the freeze node is placed after 8980 -- the generic body. Otherwise, if the generic appears in an instance, 8981 -- we cannot freeze the current instance until the outer one is frozen. 8982 -- This is only relevant if the current instance is nested within some 8983 -- inner scope not itself within the outer instance. If this scope is 8984 -- a package body in the same declarative part as the outer instance, 8985 -- then that body needs to be frozen after the outer instance. Finally, 8986 -- if no delay is needed, we place the freeze node at the end of the 8987 -- current declarative part. 8988 8989 if Expander_Active then 8990 Ensure_Freeze_Node (Act_Id); 8991 F_Node := Freeze_Node (Act_Id); 8992 8993 if Must_Delay then 8994 Insert_After (Orig_Body, F_Node); 8995 8996 elsif Is_Generic_Instance (Par) 8997 and then Present (Freeze_Node (Par)) 8998 and then Scope (Act_Id) /= Par 8999 then 9000 -- Freeze instance of inner generic after instance of enclosing 9001 -- generic. 9002 9003 if In_Same_Declarative_Part (Freeze_Node (Par), N) then 9004 9005 -- Handle the following case: 9006 9007 -- package Parent_Inst is new ... 9008 -- Parent_Inst [] 9009 9010 -- procedure P ... -- this body freezes Parent_Inst 9011 9012 -- package Inst is new ... 9013 9014 -- In this particular scenario, the freeze node for Inst must 9015 -- be inserted in the same manner as that of Parent_Inst, 9016 -- before the next source body or at the end of the declarative 9017 -- list (body not available). If body P did not exist and 9018 -- Parent_Inst was frozen after Inst, either by a body 9019 -- following Inst or at the end of the declarative region, 9020 -- the freeze node for Inst must be inserted after that of 9021 -- Parent_Inst. This relation is established by comparing 9022 -- the Slocs of Parent_Inst freeze node and Inst. 9023 9024 if List_Containing (Get_Package_Instantiation_Node (Par)) = 9025 List_Containing (N) 9026 and then Sloc (Freeze_Node (Par)) < Sloc (N) 9027 then 9028 Insert_Freeze_Node_For_Instance (N, F_Node); 9029 else 9030 Insert_After (Freeze_Node (Par), F_Node); 9031 end if; 9032 9033 -- Freeze package enclosing instance of inner generic after 9034 -- instance of enclosing generic. 9035 9036 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 9037 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) 9038 then 9039 declare 9040 Enclosing : Entity_Id; 9041 9042 begin 9043 Enclosing := Corresponding_Spec (Parent (N)); 9044 9045 if No (Enclosing) then 9046 Enclosing := Defining_Entity (Parent (N)); 9047 end if; 9048 9049 Insert_Freeze_Node_For_Instance (N, F_Node); 9050 Ensure_Freeze_Node (Enclosing); 9051 9052 if not Is_List_Member (Freeze_Node (Enclosing)) then 9053 9054 -- The enclosing context is a subunit, insert the freeze 9055 -- node after the stub. 9056 9057 if Nkind (Parent (Parent (N))) = N_Subunit then 9058 Insert_Freeze_Node_For_Instance 9059 (Corresponding_Stub (Parent (Parent (N))), 9060 Freeze_Node (Enclosing)); 9061 9062 -- The enclosing context is a package with a stub body 9063 -- which has already been replaced by the real body. 9064 -- Insert the freeze node after the actual body. 9065 9066 elsif Ekind (Enclosing) = E_Package 9067 and then Present (Body_Entity (Enclosing)) 9068 and then Was_Originally_Stub 9069 (Parent (Body_Entity (Enclosing))) 9070 then 9071 Insert_Freeze_Node_For_Instance 9072 (Parent (Body_Entity (Enclosing)), 9073 Freeze_Node (Enclosing)); 9074 9075 -- The parent instance has been frozen before the body of 9076 -- the enclosing package, insert the freeze node after 9077 -- the body. 9078 9079 elsif List_Containing (Freeze_Node (Par)) = 9080 List_Containing (Parent (N)) 9081 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 9082 then 9083 Insert_Freeze_Node_For_Instance 9084 (Parent (N), Freeze_Node (Enclosing)); 9085 9086 else 9087 Insert_After 9088 (Freeze_Node (Par), Freeze_Node (Enclosing)); 9089 end if; 9090 end if; 9091 end; 9092 9093 else 9094 Insert_Freeze_Node_For_Instance (N, F_Node); 9095 end if; 9096 9097 else 9098 Insert_Freeze_Node_For_Instance (N, F_Node); 9099 end if; 9100 end if; 9101 9102 Set_Is_Frozen (Act_Id); 9103 Insert_Before (N, Act_Body); 9104 Mark_Rewrite_Insertion (Act_Body); 9105 end Install_Body; 9106 9107 ----------------------------- 9108 -- Install_Formal_Packages -- 9109 ----------------------------- 9110 9111 procedure Install_Formal_Packages (Par : Entity_Id) is 9112 E : Entity_Id; 9113 Gen : Entity_Id; 9114 Gen_E : Entity_Id := Empty; 9115 9116 begin 9117 E := First_Entity (Par); 9118 9119 -- If we are installing an instance parent, locate the formal packages 9120 -- of its generic parent. 9121 9122 if Is_Generic_Instance (Par) then 9123 Gen := Generic_Parent (Package_Specification (Par)); 9124 Gen_E := First_Entity (Gen); 9125 end if; 9126 9127 while Present (E) loop 9128 if Ekind (E) = E_Package 9129 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 9130 then 9131 -- If this is the renaming for the parent instance, done 9132 9133 if Renamed_Object (E) = Par then 9134 exit; 9135 9136 -- The visibility of a formal of an enclosing generic is already 9137 -- correct. 9138 9139 elsif Denotes_Formal_Package (E) then 9140 null; 9141 9142 elsif Present (Associated_Formal_Package (E)) then 9143 Check_Generic_Actuals (Renamed_Object (E), True); 9144 Set_Is_Hidden (E, False); 9145 9146 -- Find formal package in generic unit that corresponds to 9147 -- (instance of) formal package in instance. 9148 9149 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 9150 Next_Entity (Gen_E); 9151 end loop; 9152 9153 if Present (Gen_E) then 9154 Map_Formal_Package_Entities (Gen_E, E); 9155 end if; 9156 end if; 9157 end if; 9158 9159 Next_Entity (E); 9160 9161 if Present (Gen_E) then 9162 Next_Entity (Gen_E); 9163 end if; 9164 end loop; 9165 end Install_Formal_Packages; 9166 9167 -------------------- 9168 -- Install_Parent -- 9169 -------------------- 9170 9171 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 9172 Ancestors : constant Elist_Id := New_Elmt_List; 9173 S : constant Entity_Id := Current_Scope; 9174 Inst_Par : Entity_Id; 9175 First_Par : Entity_Id; 9176 Inst_Node : Node_Id; 9177 Gen_Par : Entity_Id; 9178 First_Gen : Entity_Id; 9179 Elmt : Elmt_Id; 9180 9181 procedure Install_Noninstance_Specs (Par : Entity_Id); 9182 -- Install the scopes of noninstance parent units ending with Par 9183 9184 procedure Install_Spec (Par : Entity_Id); 9185 -- The child unit is within the declarative part of the parent, so the 9186 -- declarations within the parent are immediately visible. 9187 9188 ------------------------------- 9189 -- Install_Noninstance_Specs -- 9190 ------------------------------- 9191 9192 procedure Install_Noninstance_Specs (Par : Entity_Id) is 9193 begin 9194 if Present (Par) 9195 and then Par /= Standard_Standard 9196 and then not In_Open_Scopes (Par) 9197 then 9198 Install_Noninstance_Specs (Scope (Par)); 9199 Install_Spec (Par); 9200 end if; 9201 end Install_Noninstance_Specs; 9202 9203 ------------------ 9204 -- Install_Spec -- 9205 ------------------ 9206 9207 procedure Install_Spec (Par : Entity_Id) is 9208 Spec : constant Node_Id := Package_Specification (Par); 9209 9210 begin 9211 -- If this parent of the child instance is a top-level unit, 9212 -- then record the unit and its visibility for later resetting in 9213 -- Remove_Parent. We exclude units that are generic instances, as we 9214 -- only want to record this information for the ultimate top-level 9215 -- noninstance parent (is that always correct???). 9216 9217 if Scope (Par) = Standard_Standard 9218 and then not Is_Generic_Instance (Par) 9219 then 9220 Parent_Unit_Visible := Is_Immediately_Visible (Par); 9221 Instance_Parent_Unit := Par; 9222 end if; 9223 9224 -- Open the parent scope and make it and its declarations visible. 9225 -- If this point is not within a body, then only the visible 9226 -- declarations should be made visible, and installation of the 9227 -- private declarations is deferred until the appropriate point 9228 -- within analysis of the spec being instantiated (see the handling 9229 -- of parent visibility in Analyze_Package_Specification). This is 9230 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 9231 -- private view problems that occur when compiling instantiations of 9232 -- a generic child of that package (Generic_Dispatching_Constructor). 9233 -- If the instance freezes a tagged type, inlinings of operations 9234 -- from Ada.Tags may need the full view of type Tag. If inlining took 9235 -- proper account of establishing visibility of inlined subprograms' 9236 -- parents then it should be possible to remove this 9237 -- special check. ??? 9238 9239 Push_Scope (Par); 9240 Set_Is_Immediately_Visible (Par); 9241 Install_Visible_Declarations (Par); 9242 Set_Use (Visible_Declarations (Spec)); 9243 9244 if In_Body or else Is_RTU (Par, Ada_Tags) then 9245 Install_Private_Declarations (Par); 9246 Set_Use (Private_Declarations (Spec)); 9247 end if; 9248 end Install_Spec; 9249 9250 -- Start of processing for Install_Parent 9251 9252 begin 9253 -- We need to install the parent instance to compile the instantiation 9254 -- of the child, but the child instance must appear in the current 9255 -- scope. Given that we cannot place the parent above the current scope 9256 -- in the scope stack, we duplicate the current scope and unstack both 9257 -- after the instantiation is complete. 9258 9259 -- If the parent is itself the instantiation of a child unit, we must 9260 -- also stack the instantiation of its parent, and so on. Each such 9261 -- ancestor is the prefix of the name in a prior instantiation. 9262 9263 -- If this is a nested instance, the parent unit itself resolves to 9264 -- a renaming of the parent instance, whose declaration we need. 9265 9266 -- Finally, the parent may be a generic (not an instance) when the 9267 -- child unit appears as a formal package. 9268 9269 Inst_Par := P; 9270 9271 if Present (Renamed_Entity (Inst_Par)) then 9272 Inst_Par := Renamed_Entity (Inst_Par); 9273 end if; 9274 9275 First_Par := Inst_Par; 9276 9277 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9278 9279 First_Gen := Gen_Par; 9280 9281 while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop 9282 9283 -- Load grandparent instance as well 9284 9285 Inst_Node := Get_Package_Instantiation_Node (Inst_Par); 9286 9287 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 9288 Inst_Par := Entity (Prefix (Name (Inst_Node))); 9289 9290 if Present (Renamed_Entity (Inst_Par)) then 9291 Inst_Par := Renamed_Entity (Inst_Par); 9292 end if; 9293 9294 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9295 9296 if Present (Gen_Par) then 9297 Prepend_Elmt (Inst_Par, Ancestors); 9298 9299 else 9300 -- Parent is not the name of an instantiation 9301 9302 Install_Noninstance_Specs (Inst_Par); 9303 exit; 9304 end if; 9305 9306 else 9307 -- Previous error 9308 9309 exit; 9310 end if; 9311 end loop; 9312 9313 if Present (First_Gen) then 9314 Append_Elmt (First_Par, Ancestors); 9315 else 9316 Install_Noninstance_Specs (First_Par); 9317 end if; 9318 9319 if not Is_Empty_Elmt_List (Ancestors) then 9320 Elmt := First_Elmt (Ancestors); 9321 while Present (Elmt) loop 9322 Install_Spec (Node (Elmt)); 9323 Install_Formal_Packages (Node (Elmt)); 9324 Next_Elmt (Elmt); 9325 end loop; 9326 end if; 9327 9328 if not In_Body then 9329 Push_Scope (S); 9330 end if; 9331 end Install_Parent; 9332 9333 ------------------------------- 9334 -- Install_Hidden_Primitives -- 9335 ------------------------------- 9336 9337 procedure Install_Hidden_Primitives 9338 (Prims_List : in out Elist_Id; 9339 Gen_T : Entity_Id; 9340 Act_T : Entity_Id) 9341 is 9342 Elmt : Elmt_Id; 9343 List : Elist_Id := No_Elist; 9344 Prim_G_Elmt : Elmt_Id; 9345 Prim_A_Elmt : Elmt_Id; 9346 Prim_G : Node_Id; 9347 Prim_A : Node_Id; 9348 9349 begin 9350 -- No action needed in case of serious errors because we cannot trust 9351 -- in the order of primitives 9352 9353 if Serious_Errors_Detected > 0 then 9354 return; 9355 9356 -- No action possible if we don't have available the list of primitive 9357 -- operations 9358 9359 elsif No (Gen_T) 9360 or else not Is_Record_Type (Gen_T) 9361 or else not Is_Tagged_Type (Gen_T) 9362 or else not Is_Record_Type (Act_T) 9363 or else not Is_Tagged_Type (Act_T) 9364 then 9365 return; 9366 9367 -- There is no need to handle interface types since their primitives 9368 -- cannot be hidden 9369 9370 elsif Is_Interface (Gen_T) then 9371 return; 9372 end if; 9373 9374 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 9375 9376 if not Is_Class_Wide_Type (Act_T) then 9377 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 9378 else 9379 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 9380 end if; 9381 9382 loop 9383 -- Skip predefined primitives in the generic formal 9384 9385 while Present (Prim_G_Elmt) 9386 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 9387 loop 9388 Next_Elmt (Prim_G_Elmt); 9389 end loop; 9390 9391 -- Skip predefined primitives in the generic actual 9392 9393 while Present (Prim_A_Elmt) 9394 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 9395 loop 9396 Next_Elmt (Prim_A_Elmt); 9397 end loop; 9398 9399 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 9400 9401 Prim_G := Node (Prim_G_Elmt); 9402 Prim_A := Node (Prim_A_Elmt); 9403 9404 -- There is no need to handle interface primitives because their 9405 -- primitives are not hidden 9406 9407 exit when Present (Interface_Alias (Prim_G)); 9408 9409 -- Here we install one hidden primitive 9410 9411 if Chars (Prim_G) /= Chars (Prim_A) 9412 and then Has_Suffix (Prim_A, 'P') 9413 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 9414 then 9415 Set_Chars (Prim_A, Chars (Prim_G)); 9416 Append_New_Elmt (Prim_A, To => List); 9417 end if; 9418 9419 Next_Elmt (Prim_A_Elmt); 9420 Next_Elmt (Prim_G_Elmt); 9421 end loop; 9422 9423 -- Append the elements to the list of temporarily visible primitives 9424 -- avoiding duplicates. 9425 9426 if Present (List) then 9427 if No (Prims_List) then 9428 Prims_List := New_Elmt_List; 9429 end if; 9430 9431 Elmt := First_Elmt (List); 9432 while Present (Elmt) loop 9433 Append_Unique_Elmt (Node (Elmt), Prims_List); 9434 Next_Elmt (Elmt); 9435 end loop; 9436 end if; 9437 end Install_Hidden_Primitives; 9438 9439 ------------------------------- 9440 -- Restore_Hidden_Primitives -- 9441 ------------------------------- 9442 9443 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 9444 Prim_Elmt : Elmt_Id; 9445 Prim : Node_Id; 9446 9447 begin 9448 if Prims_List /= No_Elist then 9449 Prim_Elmt := First_Elmt (Prims_List); 9450 while Present (Prim_Elmt) loop 9451 Prim := Node (Prim_Elmt); 9452 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 9453 Next_Elmt (Prim_Elmt); 9454 end loop; 9455 9456 Prims_List := No_Elist; 9457 end if; 9458 end Restore_Hidden_Primitives; 9459 9460 -------------------------------- 9461 -- Instantiate_Formal_Package -- 9462 -------------------------------- 9463 9464 function Instantiate_Formal_Package 9465 (Formal : Node_Id; 9466 Actual : Node_Id; 9467 Analyzed_Formal : Node_Id) return List_Id 9468 is 9469 Loc : constant Source_Ptr := Sloc (Actual); 9470 Actual_Pack : Entity_Id; 9471 Formal_Pack : Entity_Id; 9472 Gen_Parent : Entity_Id; 9473 Decls : List_Id; 9474 Nod : Node_Id; 9475 Parent_Spec : Node_Id; 9476 9477 procedure Find_Matching_Actual 9478 (F : Node_Id; 9479 Act : in out Entity_Id); 9480 -- We need to associate each formal entity in the formal package with 9481 -- the corresponding entity in the actual package. The actual package 9482 -- has been analyzed and possibly expanded, and as a result there is 9483 -- no one-to-one correspondence between the two lists (for example, 9484 -- the actual may include subtypes, itypes, and inherited primitive 9485 -- operations, interspersed among the renaming declarations for the 9486 -- actuals). We retrieve the corresponding actual by name because each 9487 -- actual has the same name as the formal, and they do appear in the 9488 -- same order. 9489 9490 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 9491 -- Retrieve entity of defining entity of generic formal parameter. 9492 -- Only the declarations of formals need to be considered when 9493 -- linking them to actuals, but the declarative list may include 9494 -- internal entities generated during analysis, and those are ignored. 9495 9496 procedure Match_Formal_Entity 9497 (Formal_Node : Node_Id; 9498 Formal_Ent : Entity_Id; 9499 Actual_Ent : Entity_Id); 9500 -- Associates the formal entity with the actual. In the case where 9501 -- Formal_Ent is a formal package, this procedure iterates through all 9502 -- of its formals and enters associations between the actuals occurring 9503 -- in the formal package's corresponding actual package (given by 9504 -- Actual_Ent) and the formal package's formal parameters. This 9505 -- procedure recurses if any of the parameters is itself a package. 9506 9507 function Is_Instance_Of 9508 (Act_Spec : Entity_Id; 9509 Gen_Anc : Entity_Id) return Boolean; 9510 -- The actual can be an instantiation of a generic within another 9511 -- instance, in which case there is no direct link from it to the 9512 -- original generic ancestor. In that case, we recognize that the 9513 -- ultimate ancestor is the same by examining names and scopes. 9514 9515 procedure Process_Nested_Formal (Formal : Entity_Id); 9516 -- If the current formal is declared with a box, its own formals are 9517 -- visible in the instance, as they were in the generic, and their 9518 -- Hidden flag must be reset. If some of these formals are themselves 9519 -- packages declared with a box, the processing must be recursive. 9520 9521 -------------------------- 9522 -- Find_Matching_Actual -- 9523 -------------------------- 9524 9525 procedure Find_Matching_Actual 9526 (F : Node_Id; 9527 Act : in out Entity_Id) 9528 is 9529 Formal_Ent : Entity_Id; 9530 9531 begin 9532 case Nkind (Original_Node (F)) is 9533 when N_Formal_Object_Declaration | 9534 N_Formal_Type_Declaration => 9535 Formal_Ent := Defining_Identifier (F); 9536 9537 while Chars (Act) /= Chars (Formal_Ent) loop 9538 Next_Entity (Act); 9539 end loop; 9540 9541 when N_Formal_Subprogram_Declaration | 9542 N_Formal_Package_Declaration | 9543 N_Package_Declaration | 9544 N_Generic_Package_Declaration => 9545 Formal_Ent := Defining_Entity (F); 9546 9547 while Chars (Act) /= Chars (Formal_Ent) loop 9548 Next_Entity (Act); 9549 end loop; 9550 9551 when others => 9552 raise Program_Error; 9553 end case; 9554 end Find_Matching_Actual; 9555 9556 ------------------------- 9557 -- Match_Formal_Entity -- 9558 ------------------------- 9559 9560 procedure Match_Formal_Entity 9561 (Formal_Node : Node_Id; 9562 Formal_Ent : Entity_Id; 9563 Actual_Ent : Entity_Id) 9564 is 9565 Act_Pkg : Entity_Id; 9566 9567 begin 9568 Set_Instance_Of (Formal_Ent, Actual_Ent); 9569 9570 if Ekind (Actual_Ent) = E_Package then 9571 9572 -- Record associations for each parameter 9573 9574 Act_Pkg := Actual_Ent; 9575 9576 declare 9577 A_Ent : Entity_Id := First_Entity (Act_Pkg); 9578 F_Ent : Entity_Id; 9579 F_Node : Node_Id; 9580 9581 Gen_Decl : Node_Id; 9582 Formals : List_Id; 9583 Actual : Entity_Id; 9584 9585 begin 9586 -- Retrieve the actual given in the formal package declaration 9587 9588 Actual := Entity (Name (Original_Node (Formal_Node))); 9589 9590 -- The actual in the formal package declaration may be a 9591 -- renamed generic package, in which case we want to retrieve 9592 -- the original generic in order to traverse its formal part. 9593 9594 if Present (Renamed_Entity (Actual)) then 9595 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 9596 else 9597 Gen_Decl := Unit_Declaration_Node (Actual); 9598 end if; 9599 9600 Formals := Generic_Formal_Declarations (Gen_Decl); 9601 9602 if Present (Formals) then 9603 F_Node := First_Non_Pragma (Formals); 9604 else 9605 F_Node := Empty; 9606 end if; 9607 9608 while Present (A_Ent) 9609 and then Present (F_Node) 9610 and then A_Ent /= First_Private_Entity (Act_Pkg) 9611 loop 9612 F_Ent := Get_Formal_Entity (F_Node); 9613 9614 if Present (F_Ent) then 9615 9616 -- This is a formal of the original package. Record 9617 -- association and recurse. 9618 9619 Find_Matching_Actual (F_Node, A_Ent); 9620 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 9621 Next_Entity (A_Ent); 9622 end if; 9623 9624 Next_Non_Pragma (F_Node); 9625 end loop; 9626 end; 9627 end if; 9628 end Match_Formal_Entity; 9629 9630 ----------------------- 9631 -- Get_Formal_Entity -- 9632 ----------------------- 9633 9634 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 9635 Kind : constant Node_Kind := Nkind (Original_Node (N)); 9636 begin 9637 case Kind is 9638 when N_Formal_Object_Declaration => 9639 return Defining_Identifier (N); 9640 9641 when N_Formal_Type_Declaration => 9642 return Defining_Identifier (N); 9643 9644 when N_Formal_Subprogram_Declaration => 9645 return Defining_Unit_Name (Specification (N)); 9646 9647 when N_Formal_Package_Declaration => 9648 return Defining_Identifier (Original_Node (N)); 9649 9650 when N_Generic_Package_Declaration => 9651 return Defining_Identifier (Original_Node (N)); 9652 9653 -- All other declarations are introduced by semantic analysis and 9654 -- have no match in the actual. 9655 9656 when others => 9657 return Empty; 9658 end case; 9659 end Get_Formal_Entity; 9660 9661 -------------------- 9662 -- Is_Instance_Of -- 9663 -------------------- 9664 9665 function Is_Instance_Of 9666 (Act_Spec : Entity_Id; 9667 Gen_Anc : Entity_Id) return Boolean 9668 is 9669 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 9670 9671 begin 9672 if No (Gen_Par) then 9673 return False; 9674 9675 -- Simplest case: the generic parent of the actual is the formal 9676 9677 elsif Gen_Par = Gen_Anc then 9678 return True; 9679 9680 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 9681 return False; 9682 9683 -- The actual may be obtained through several instantiations. Its 9684 -- scope must itself be an instance of a generic declared in the 9685 -- same scope as the formal. Any other case is detected above. 9686 9687 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 9688 return False; 9689 9690 else 9691 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 9692 end if; 9693 end Is_Instance_Of; 9694 9695 --------------------------- 9696 -- Process_Nested_Formal -- 9697 --------------------------- 9698 9699 procedure Process_Nested_Formal (Formal : Entity_Id) is 9700 Ent : Entity_Id; 9701 9702 begin 9703 if Present (Associated_Formal_Package (Formal)) 9704 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 9705 then 9706 Ent := First_Entity (Formal); 9707 while Present (Ent) loop 9708 Set_Is_Hidden (Ent, False); 9709 Set_Is_Visible_Formal (Ent); 9710 Set_Is_Potentially_Use_Visible 9711 (Ent, Is_Potentially_Use_Visible (Formal)); 9712 9713 if Ekind (Ent) = E_Package then 9714 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 9715 Process_Nested_Formal (Ent); 9716 end if; 9717 9718 Next_Entity (Ent); 9719 end loop; 9720 end if; 9721 end Process_Nested_Formal; 9722 9723 -- Start of processing for Instantiate_Formal_Package 9724 9725 begin 9726 Analyze (Actual); 9727 9728 if not Is_Entity_Name (Actual) 9729 or else Ekind (Entity (Actual)) /= E_Package 9730 then 9731 Error_Msg_N 9732 ("expect package instance to instantiate formal", Actual); 9733 Abandon_Instantiation (Actual); 9734 raise Program_Error; 9735 9736 else 9737 Actual_Pack := Entity (Actual); 9738 Set_Is_Instantiated (Actual_Pack); 9739 9740 -- The actual may be a renamed package, or an outer generic formal 9741 -- package whose instantiation is converted into a renaming. 9742 9743 if Present (Renamed_Object (Actual_Pack)) then 9744 Actual_Pack := Renamed_Object (Actual_Pack); 9745 end if; 9746 9747 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 9748 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 9749 Formal_Pack := Defining_Identifier (Analyzed_Formal); 9750 else 9751 Gen_Parent := 9752 Generic_Parent (Specification (Analyzed_Formal)); 9753 Formal_Pack := 9754 Defining_Unit_Name (Specification (Analyzed_Formal)); 9755 end if; 9756 9757 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 9758 Parent_Spec := Package_Specification (Actual_Pack); 9759 else 9760 Parent_Spec := Parent (Actual_Pack); 9761 end if; 9762 9763 if Gen_Parent = Any_Id then 9764 Error_Msg_N 9765 ("previous error in declaration of formal package", Actual); 9766 Abandon_Instantiation (Actual); 9767 9768 elsif 9769 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) 9770 then 9771 null; 9772 9773 else 9774 Error_Msg_NE 9775 ("actual parameter must be instance of&", Actual, Gen_Parent); 9776 Abandon_Instantiation (Actual); 9777 end if; 9778 9779 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 9780 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 9781 9782 Nod := 9783 Make_Package_Renaming_Declaration (Loc, 9784 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 9785 Name => New_Occurrence_Of (Actual_Pack, Loc)); 9786 9787 Set_Associated_Formal_Package 9788 (Defining_Unit_Name (Nod), Defining_Identifier (Formal)); 9789 Decls := New_List (Nod); 9790 9791 -- If the formal F has a box, then the generic declarations are 9792 -- visible in the generic G. In an instance of G, the corresponding 9793 -- entities in the actual for F (which are the actuals for the 9794 -- instantiation of the generic that F denotes) must also be made 9795 -- visible for analysis of the current instance. On exit from the 9796 -- current instance, those entities are made private again. If the 9797 -- actual is currently in use, these entities are also use-visible. 9798 9799 -- The loop through the actual entities also steps through the formal 9800 -- entities and enters associations from formals to actuals into the 9801 -- renaming map. This is necessary to properly handle checking of 9802 -- actual parameter associations for later formals that depend on 9803 -- actuals declared in the formal package. 9804 9805 -- In Ada 2005, partial parameterization requires that we make 9806 -- visible the actuals corresponding to formals that were defaulted 9807 -- in the formal package. There formals are identified because they 9808 -- remain formal generics within the formal package, rather than 9809 -- being renamings of the actuals supplied. 9810 9811 declare 9812 Gen_Decl : constant Node_Id := 9813 Unit_Declaration_Node (Gen_Parent); 9814 Formals : constant List_Id := 9815 Generic_Formal_Declarations (Gen_Decl); 9816 9817 Actual_Ent : Entity_Id; 9818 Actual_Of_Formal : Node_Id; 9819 Formal_Node : Node_Id; 9820 Formal_Ent : Entity_Id; 9821 9822 begin 9823 if Present (Formals) then 9824 Formal_Node := First_Non_Pragma (Formals); 9825 else 9826 Formal_Node := Empty; 9827 end if; 9828 9829 Actual_Ent := First_Entity (Actual_Pack); 9830 Actual_Of_Formal := 9831 First (Visible_Declarations (Specification (Analyzed_Formal))); 9832 while Present (Actual_Ent) 9833 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9834 loop 9835 if Present (Formal_Node) then 9836 Formal_Ent := Get_Formal_Entity (Formal_Node); 9837 9838 if Present (Formal_Ent) then 9839 Find_Matching_Actual (Formal_Node, Actual_Ent); 9840 Match_Formal_Entity (Formal_Node, Formal_Ent, Actual_Ent); 9841 9842 -- We iterate at the same time over the actuals of the 9843 -- local package created for the formal, to determine 9844 -- which one of the formals of the original generic were 9845 -- defaulted in the formal. The corresponding actual 9846 -- entities are visible in the enclosing instance. 9847 9848 if Box_Present (Formal) 9849 or else 9850 (Present (Actual_Of_Formal) 9851 and then 9852 Is_Generic_Formal 9853 (Get_Formal_Entity (Actual_Of_Formal))) 9854 then 9855 Set_Is_Hidden (Actual_Ent, False); 9856 Set_Is_Visible_Formal (Actual_Ent); 9857 Set_Is_Potentially_Use_Visible 9858 (Actual_Ent, In_Use (Actual_Pack)); 9859 9860 if Ekind (Actual_Ent) = E_Package then 9861 Process_Nested_Formal (Actual_Ent); 9862 end if; 9863 9864 else 9865 Set_Is_Hidden (Actual_Ent); 9866 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 9867 end if; 9868 end if; 9869 9870 Next_Non_Pragma (Formal_Node); 9871 Next (Actual_Of_Formal); 9872 9873 else 9874 -- No further formals to match, but the generic part may 9875 -- contain inherited operation that are not hidden in the 9876 -- enclosing instance. 9877 9878 Next_Entity (Actual_Ent); 9879 end if; 9880 end loop; 9881 9882 -- Inherited subprograms generated by formal derived types are 9883 -- also visible if the types are. 9884 9885 Actual_Ent := First_Entity (Actual_Pack); 9886 while Present (Actual_Ent) 9887 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9888 loop 9889 if Is_Overloadable (Actual_Ent) 9890 and then 9891 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 9892 and then 9893 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 9894 then 9895 Set_Is_Hidden (Actual_Ent, False); 9896 Set_Is_Potentially_Use_Visible 9897 (Actual_Ent, In_Use (Actual_Pack)); 9898 end if; 9899 9900 Next_Entity (Actual_Ent); 9901 end loop; 9902 end; 9903 9904 -- If the formal is not declared with a box, reanalyze it as an 9905 -- abbreviated instantiation, to verify the matching rules of 12.7. 9906 -- The actual checks are performed after the generic associations 9907 -- have been analyzed, to guarantee the same visibility for this 9908 -- instantiation and for the actuals. 9909 9910 -- In Ada 2005, the generic associations for the formal can include 9911 -- defaulted parameters. These are ignored during check. This 9912 -- internal instantiation is removed from the tree after conformance 9913 -- checking, because it contains formal declarations for those 9914 -- defaulted parameters, and those should not reach the back-end. 9915 9916 if not Box_Present (Formal) then 9917 declare 9918 I_Pack : constant Entity_Id := 9919 Make_Temporary (Sloc (Actual), 'P'); 9920 9921 begin 9922 Set_Is_Internal (I_Pack); 9923 9924 Append_To (Decls, 9925 Make_Package_Instantiation (Sloc (Actual), 9926 Defining_Unit_Name => I_Pack, 9927 Name => 9928 New_Occurrence_Of 9929 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 9930 Generic_Associations => Generic_Associations (Formal))); 9931 end; 9932 end if; 9933 9934 return Decls; 9935 end if; 9936 end Instantiate_Formal_Package; 9937 9938 ----------------------------------- 9939 -- Instantiate_Formal_Subprogram -- 9940 ----------------------------------- 9941 9942 function Instantiate_Formal_Subprogram 9943 (Formal : Node_Id; 9944 Actual : Node_Id; 9945 Analyzed_Formal : Node_Id) return Node_Id 9946 is 9947 Analyzed_S : constant Entity_Id := 9948 Defining_Unit_Name (Specification (Analyzed_Formal)); 9949 Formal_Sub : constant Entity_Id := 9950 Defining_Unit_Name (Specification (Formal)); 9951 9952 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 9953 -- If the generic is a child unit, the parent has been installed on the 9954 -- scope stack, but a default subprogram cannot resolve to something 9955 -- on the parent because that parent is not really part of the visible 9956 -- context (it is there to resolve explicit local entities). If the 9957 -- default has resolved in this way, we remove the entity from immediate 9958 -- visibility and analyze the node again to emit an error message or 9959 -- find another visible candidate. 9960 9961 procedure Valid_Actual_Subprogram (Act : Node_Id); 9962 -- Perform legality check and raise exception on failure 9963 9964 ----------------------- 9965 -- From_Parent_Scope -- 9966 ----------------------- 9967 9968 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 9969 Gen_Scope : Node_Id; 9970 9971 begin 9972 Gen_Scope := Scope (Analyzed_S); 9973 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 9974 if Scope (Subp) = Scope (Gen_Scope) then 9975 return True; 9976 end if; 9977 9978 Gen_Scope := Scope (Gen_Scope); 9979 end loop; 9980 9981 return False; 9982 end From_Parent_Scope; 9983 9984 ----------------------------- 9985 -- Valid_Actual_Subprogram -- 9986 ----------------------------- 9987 9988 procedure Valid_Actual_Subprogram (Act : Node_Id) is 9989 Act_E : Entity_Id; 9990 9991 begin 9992 if Is_Entity_Name (Act) then 9993 Act_E := Entity (Act); 9994 9995 elsif Nkind (Act) = N_Selected_Component 9996 and then Is_Entity_Name (Selector_Name (Act)) 9997 then 9998 Act_E := Entity (Selector_Name (Act)); 9999 10000 else 10001 Act_E := Empty; 10002 end if; 10003 10004 if (Present (Act_E) and then Is_Overloadable (Act_E)) 10005 or else Nkind_In (Act, N_Attribute_Reference, 10006 N_Indexed_Component, 10007 N_Character_Literal, 10008 N_Explicit_Dereference) 10009 then 10010 return; 10011 end if; 10012 10013 Error_Msg_NE 10014 ("expect subprogram or entry name in instantiation of &", 10015 Instantiation_Node, Formal_Sub); 10016 Abandon_Instantiation (Instantiation_Node); 10017 end Valid_Actual_Subprogram; 10018 10019 -- Local variables 10020 10021 Decl_Node : Node_Id; 10022 Loc : Source_Ptr; 10023 Nam : Node_Id; 10024 New_Spec : Node_Id; 10025 New_Subp : Entity_Id; 10026 10027 -- Start of processing for Instantiate_Formal_Subprogram 10028 10029 begin 10030 New_Spec := New_Copy_Tree (Specification (Formal)); 10031 10032 -- The tree copy has created the proper instantiation sloc for the 10033 -- new specification. Use this location for all other constructed 10034 -- declarations. 10035 10036 Loc := Sloc (Defining_Unit_Name (New_Spec)); 10037 10038 -- Create new entity for the actual (New_Copy_Tree does not), and 10039 -- indicate that it is an actual. 10040 10041 New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); 10042 Set_Ekind (New_Subp, Ekind (Analyzed_S)); 10043 Set_Is_Generic_Actual_Subprogram (New_Subp); 10044 Set_Defining_Unit_Name (New_Spec, New_Subp); 10045 10046 -- Create new entities for the each of the formals in the specification 10047 -- of the renaming declaration built for the actual. 10048 10049 if Present (Parameter_Specifications (New_Spec)) then 10050 declare 10051 F : Node_Id; 10052 F_Id : Entity_Id; 10053 10054 begin 10055 F := First (Parameter_Specifications (New_Spec)); 10056 while Present (F) loop 10057 F_Id := Defining_Identifier (F); 10058 10059 Set_Defining_Identifier (F, 10060 Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id))); 10061 Next (F); 10062 end loop; 10063 end; 10064 end if; 10065 10066 -- Find entity of actual. If the actual is an attribute reference, it 10067 -- cannot be resolved here (its formal is missing) but is handled 10068 -- instead in Attribute_Renaming. If the actual is overloaded, it is 10069 -- fully resolved subsequently, when the renaming declaration for the 10070 -- formal is analyzed. If it is an explicit dereference, resolve the 10071 -- prefix but not the actual itself, to prevent interpretation as call. 10072 10073 if Present (Actual) then 10074 Loc := Sloc (Actual); 10075 Set_Sloc (New_Spec, Loc); 10076 10077 if Nkind (Actual) = N_Operator_Symbol then 10078 Find_Direct_Name (Actual); 10079 10080 elsif Nkind (Actual) = N_Explicit_Dereference then 10081 Analyze (Prefix (Actual)); 10082 10083 elsif Nkind (Actual) /= N_Attribute_Reference then 10084 Analyze (Actual); 10085 end if; 10086 10087 Valid_Actual_Subprogram (Actual); 10088 Nam := Actual; 10089 10090 elsif Present (Default_Name (Formal)) then 10091 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 10092 N_Selected_Component, 10093 N_Indexed_Component, 10094 N_Character_Literal) 10095 and then Present (Entity (Default_Name (Formal))) 10096 then 10097 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 10098 else 10099 Nam := New_Copy (Default_Name (Formal)); 10100 Set_Sloc (Nam, Loc); 10101 end if; 10102 10103 elsif Box_Present (Formal) then 10104 10105 -- Actual is resolved at the point of instantiation. Create an 10106 -- identifier or operator with the same name as the formal. 10107 10108 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 10109 Nam := 10110 Make_Operator_Symbol (Loc, 10111 Chars => Chars (Formal_Sub), 10112 Strval => No_String); 10113 else 10114 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 10115 end if; 10116 10117 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 10118 and then Null_Present (Specification (Formal)) 10119 then 10120 -- Generate null body for procedure, for use in the instance 10121 10122 Decl_Node := 10123 Make_Subprogram_Body (Loc, 10124 Specification => New_Spec, 10125 Declarations => New_List, 10126 Handled_Statement_Sequence => 10127 Make_Handled_Sequence_Of_Statements (Loc, 10128 Statements => New_List (Make_Null_Statement (Loc)))); 10129 10130 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 10131 return Decl_Node; 10132 10133 else 10134 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 10135 Error_Msg_NE 10136 ("missing actual&", Instantiation_Node, Formal_Sub); 10137 Error_Msg_NE 10138 ("\in instantiation of & declared#", 10139 Instantiation_Node, Scope (Analyzed_S)); 10140 Abandon_Instantiation (Instantiation_Node); 10141 end if; 10142 10143 Decl_Node := 10144 Make_Subprogram_Renaming_Declaration (Loc, 10145 Specification => New_Spec, 10146 Name => Nam); 10147 10148 -- If we do not have an actual and the formal specified <> then set to 10149 -- get proper default. 10150 10151 if No (Actual) and then Box_Present (Formal) then 10152 Set_From_Default (Decl_Node); 10153 end if; 10154 10155 -- Gather possible interpretations for the actual before analyzing the 10156 -- instance. If overloaded, it will be resolved when analyzing the 10157 -- renaming declaration. 10158 10159 if Box_Present (Formal) and then No (Actual) then 10160 Analyze (Nam); 10161 10162 if Is_Child_Unit (Scope (Analyzed_S)) 10163 and then Present (Entity (Nam)) 10164 then 10165 if not Is_Overloaded (Nam) then 10166 if From_Parent_Scope (Entity (Nam)) then 10167 Set_Is_Immediately_Visible (Entity (Nam), False); 10168 Set_Entity (Nam, Empty); 10169 Set_Etype (Nam, Empty); 10170 10171 Analyze (Nam); 10172 Set_Is_Immediately_Visible (Entity (Nam)); 10173 end if; 10174 10175 else 10176 declare 10177 I : Interp_Index; 10178 It : Interp; 10179 10180 begin 10181 Get_First_Interp (Nam, I, It); 10182 while Present (It.Nam) loop 10183 if From_Parent_Scope (It.Nam) then 10184 Remove_Interp (I); 10185 end if; 10186 10187 Get_Next_Interp (I, It); 10188 end loop; 10189 end; 10190 end if; 10191 end if; 10192 end if; 10193 10194 -- The generic instantiation freezes the actual. This can only be done 10195 -- once the actual is resolved, in the analysis of the renaming 10196 -- declaration. To make the formal subprogram entity available, we set 10197 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 10198 -- This is also needed in Analyze_Subprogram_Renaming for the processing 10199 -- of formal abstract subprograms. 10200 10201 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 10202 10203 -- We cannot analyze the renaming declaration, and thus find the actual, 10204 -- until all the actuals are assembled in the instance. For subsequent 10205 -- checks of other actuals, indicate the node that will hold the 10206 -- instance of this formal. 10207 10208 Set_Instance_Of (Analyzed_S, Nam); 10209 10210 if Nkind (Actual) = N_Selected_Component 10211 and then Is_Task_Type (Etype (Prefix (Actual))) 10212 and then not Is_Frozen (Etype (Prefix (Actual))) 10213 then 10214 -- The renaming declaration will create a body, which must appear 10215 -- outside of the instantiation, We move the renaming declaration 10216 -- out of the instance, and create an additional renaming inside, 10217 -- to prevent freezing anomalies. 10218 10219 declare 10220 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 10221 10222 begin 10223 Set_Defining_Unit_Name (New_Spec, Anon_Id); 10224 Insert_Before (Instantiation_Node, Decl_Node); 10225 Analyze (Decl_Node); 10226 10227 -- Now create renaming within the instance 10228 10229 Decl_Node := 10230 Make_Subprogram_Renaming_Declaration (Loc, 10231 Specification => New_Copy_Tree (New_Spec), 10232 Name => New_Occurrence_Of (Anon_Id, Loc)); 10233 10234 Set_Defining_Unit_Name (Specification (Decl_Node), 10235 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 10236 end; 10237 end if; 10238 10239 return Decl_Node; 10240 end Instantiate_Formal_Subprogram; 10241 10242 ------------------------ 10243 -- Instantiate_Object -- 10244 ------------------------ 10245 10246 function Instantiate_Object 10247 (Formal : Node_Id; 10248 Actual : Node_Id; 10249 Analyzed_Formal : Node_Id) return List_Id 10250 is 10251 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 10252 A_Gen_Obj : constant Entity_Id := 10253 Defining_Identifier (Analyzed_Formal); 10254 Acc_Def : Node_Id := Empty; 10255 Act_Assoc : constant Node_Id := Parent (Actual); 10256 Actual_Decl : Node_Id := Empty; 10257 Decl_Node : Node_Id; 10258 Def : Node_Id; 10259 Ftyp : Entity_Id; 10260 List : constant List_Id := New_List; 10261 Loc : constant Source_Ptr := Sloc (Actual); 10262 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 10263 Subt_Decl : Node_Id := Empty; 10264 Subt_Mark : Node_Id := Empty; 10265 10266 function Copy_Access_Def return Node_Id; 10267 -- If formal is an anonymous access, copy access definition of formal 10268 -- for generated object declaration. 10269 10270 --------------------- 10271 -- Copy_Access_Def -- 10272 --------------------- 10273 10274 function Copy_Access_Def return Node_Id is 10275 begin 10276 Def := New_Copy_Tree (Acc_Def); 10277 10278 -- In addition, if formal is an access to subprogram we need to 10279 -- generate new formals for the signature of the default, so that 10280 -- the tree is properly formatted for ASIS use. 10281 10282 if Present (Access_To_Subprogram_Definition (Acc_Def)) then 10283 declare 10284 Par_Spec : Node_Id; 10285 begin 10286 Par_Spec := 10287 First (Parameter_Specifications 10288 (Access_To_Subprogram_Definition (Def))); 10289 while Present (Par_Spec) loop 10290 Set_Defining_Identifier (Par_Spec, 10291 Make_Defining_Identifier (Sloc (Acc_Def), 10292 Chars => Chars (Defining_Identifier (Par_Spec)))); 10293 Next (Par_Spec); 10294 end loop; 10295 end; 10296 end if; 10297 10298 return Def; 10299 end Copy_Access_Def; 10300 10301 -- Start of processing for Instantiate_Object 10302 10303 begin 10304 -- Formal may be an anonymous access 10305 10306 if Present (Subtype_Mark (Formal)) then 10307 Subt_Mark := Subtype_Mark (Formal); 10308 else 10309 Check_Access_Definition (Formal); 10310 Acc_Def := Access_Definition (Formal); 10311 end if; 10312 10313 -- Sloc for error message on missing actual 10314 10315 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 10316 10317 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 10318 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 10319 end if; 10320 10321 Set_Parent (List, Parent (Actual)); 10322 10323 -- OUT present 10324 10325 if Out_Present (Formal) then 10326 10327 -- An IN OUT generic actual must be a name. The instantiation is a 10328 -- renaming declaration. The actual is the name being renamed. We 10329 -- use the actual directly, rather than a copy, because it is not 10330 -- used further in the list of actuals, and because a copy or a use 10331 -- of relocate_node is incorrect if the instance is nested within a 10332 -- generic. In order to simplify ASIS searches, the Generic_Parent 10333 -- field links the declaration to the generic association. 10334 10335 if No (Actual) then 10336 Error_Msg_NE 10337 ("missing actual &", 10338 Instantiation_Node, Gen_Obj); 10339 Error_Msg_NE 10340 ("\in instantiation of & declared#", 10341 Instantiation_Node, Scope (A_Gen_Obj)); 10342 Abandon_Instantiation (Instantiation_Node); 10343 end if; 10344 10345 if Present (Subt_Mark) then 10346 Decl_Node := 10347 Make_Object_Renaming_Declaration (Loc, 10348 Defining_Identifier => New_Copy (Gen_Obj), 10349 Subtype_Mark => New_Copy_Tree (Subt_Mark), 10350 Name => Actual); 10351 10352 else pragma Assert (Present (Acc_Def)); 10353 Decl_Node := 10354 Make_Object_Renaming_Declaration (Loc, 10355 Defining_Identifier => New_Copy (Gen_Obj), 10356 Access_Definition => New_Copy_Tree (Acc_Def), 10357 Name => Actual); 10358 end if; 10359 10360 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 10361 10362 -- The analysis of the actual may produce Insert_Action nodes, so 10363 -- the declaration must have a context in which to attach them. 10364 10365 Append (Decl_Node, List); 10366 Analyze (Actual); 10367 10368 -- Return if the analysis of the actual reported some error 10369 10370 if Etype (Actual) = Any_Type then 10371 return List; 10372 end if; 10373 10374 -- This check is performed here because Analyze_Object_Renaming will 10375 -- not check it when Comes_From_Source is False. Note though that the 10376 -- check for the actual being the name of an object will be performed 10377 -- in Analyze_Object_Renaming. 10378 10379 if Is_Object_Reference (Actual) 10380 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 10381 then 10382 Error_Msg_N 10383 ("illegal discriminant-dependent component for in out parameter", 10384 Actual); 10385 end if; 10386 10387 -- The actual has to be resolved in order to check that it is a 10388 -- variable (due to cases such as F (1), where F returns access to 10389 -- an array, and for overloaded prefixes). 10390 10391 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 10392 10393 -- If the type of the formal is not itself a formal, and the current 10394 -- unit is a child unit, the formal type must be declared in a 10395 -- parent, and must be retrieved by visibility. 10396 10397 if Ftyp = Orig_Ftyp 10398 and then Is_Generic_Unit (Scope (Ftyp)) 10399 and then Is_Child_Unit (Scope (A_Gen_Obj)) 10400 then 10401 declare 10402 Temp : constant Node_Id := 10403 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 10404 begin 10405 Set_Entity (Temp, Empty); 10406 Find_Type (Temp); 10407 Ftyp := Entity (Temp); 10408 end; 10409 end if; 10410 10411 if Is_Private_Type (Ftyp) 10412 and then not Is_Private_Type (Etype (Actual)) 10413 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 10414 or else Base_Type (Etype (Actual)) = Ftyp) 10415 then 10416 -- If the actual has the type of the full view of the formal, or 10417 -- else a non-private subtype of the formal, then the visibility 10418 -- of the formal type has changed. Add to the actuals a subtype 10419 -- declaration that will force the exchange of views in the body 10420 -- of the instance as well. 10421 10422 Subt_Decl := 10423 Make_Subtype_Declaration (Loc, 10424 Defining_Identifier => Make_Temporary (Loc, 'P'), 10425 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 10426 10427 Prepend (Subt_Decl, List); 10428 10429 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 10430 Exchange_Declarations (Ftyp); 10431 end if; 10432 10433 Resolve (Actual, Ftyp); 10434 10435 if not Denotes_Variable (Actual) then 10436 Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj); 10437 10438 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 10439 10440 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 10441 -- the type of the actual shall resolve to a specific anonymous 10442 -- access type. 10443 10444 if Ada_Version < Ada_2005 10445 or else Ekind (Base_Type (Ftyp)) /= 10446 E_Anonymous_Access_Type 10447 or else Ekind (Base_Type (Etype (Actual))) /= 10448 E_Anonymous_Access_Type 10449 then 10450 Error_Msg_NE 10451 ("type of actual does not match type of&", Actual, Gen_Obj); 10452 end if; 10453 end if; 10454 10455 Note_Possible_Modification (Actual, Sure => True); 10456 10457 -- Check for instantiation of atomic/volatile actual for 10458 -- non-atomic/volatile formal (RM C.6 (12)). 10459 10460 if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then 10461 Error_Msg_N 10462 ("cannot instantiate non-atomic formal object " 10463 & "with atomic actual", Actual); 10464 10465 elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) 10466 then 10467 Error_Msg_N 10468 ("cannot instantiate non-volatile formal object " 10469 & "with volatile actual", Actual); 10470 end if; 10471 10472 -- Formal in-parameter 10473 10474 else 10475 -- The instantiation of a generic formal in-parameter is constant 10476 -- declaration. The actual is the expression for that declaration. 10477 -- Its type is a full copy of the type of the formal. This may be 10478 -- an access to subprogram, for which we need to generate entities 10479 -- for the formals in the new signature. 10480 10481 if Present (Actual) then 10482 if Present (Subt_Mark) then 10483 Def := New_Copy_Tree (Subt_Mark); 10484 else pragma Assert (Present (Acc_Def)); 10485 Def := Copy_Access_Def; 10486 end if; 10487 10488 Decl_Node := 10489 Make_Object_Declaration (Loc, 10490 Defining_Identifier => New_Copy (Gen_Obj), 10491 Constant_Present => True, 10492 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 10493 Object_Definition => Def, 10494 Expression => Actual); 10495 10496 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 10497 10498 -- A generic formal object of a tagged type is defined to be 10499 -- aliased so the new constant must also be treated as aliased. 10500 10501 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 10502 Set_Aliased_Present (Decl_Node); 10503 end if; 10504 10505 Append (Decl_Node, List); 10506 10507 -- No need to repeat (pre-)analysis of some expression nodes 10508 -- already handled in Preanalyze_Actuals. 10509 10510 if Nkind (Actual) /= N_Allocator then 10511 Analyze (Actual); 10512 10513 -- Return if the analysis of the actual reported some error 10514 10515 if Etype (Actual) = Any_Type then 10516 return List; 10517 end if; 10518 end if; 10519 10520 declare 10521 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 10522 Typ : Entity_Id; 10523 10524 begin 10525 Typ := Get_Instance_Of (Formal_Type); 10526 10527 -- If the actual appears in the current or an enclosing scope, 10528 -- use its type directly. This is relevant if it has an actual 10529 -- subtype that is distinct from its nominal one. This cannot 10530 -- be done in general because the type of the actual may 10531 -- depend on other actuals, and only be fully determined when 10532 -- the enclosing instance is analyzed. 10533 10534 if Present (Etype (Actual)) 10535 and then Is_Constr_Subt_For_U_Nominal (Etype (Actual)) 10536 then 10537 Freeze_Before (Instantiation_Node, Etype (Actual)); 10538 else 10539 Freeze_Before (Instantiation_Node, Typ); 10540 end if; 10541 10542 -- If the actual is an aggregate, perform name resolution on 10543 -- its components (the analysis of an aggregate does not do it) 10544 -- to capture local names that may be hidden if the generic is 10545 -- a child unit. 10546 10547 if Nkind (Actual) = N_Aggregate then 10548 Preanalyze_And_Resolve (Actual, Typ); 10549 end if; 10550 10551 if Is_Limited_Type (Typ) 10552 and then not OK_For_Limited_Init (Typ, Actual) 10553 then 10554 Error_Msg_N 10555 ("initialization not allowed for limited types", Actual); 10556 Explain_Limited_Type (Typ, Actual); 10557 end if; 10558 end; 10559 10560 elsif Present (Default_Expression (Formal)) then 10561 10562 -- Use default to construct declaration 10563 10564 if Present (Subt_Mark) then 10565 Def := New_Copy (Subt_Mark); 10566 else pragma Assert (Present (Acc_Def)); 10567 Def := Copy_Access_Def; 10568 end if; 10569 10570 Decl_Node := 10571 Make_Object_Declaration (Sloc (Formal), 10572 Defining_Identifier => New_Copy (Gen_Obj), 10573 Constant_Present => True, 10574 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 10575 Object_Definition => Def, 10576 Expression => New_Copy_Tree 10577 (Default_Expression (Formal))); 10578 10579 Append (Decl_Node, List); 10580 Set_Analyzed (Expression (Decl_Node), False); 10581 10582 else 10583 Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj); 10584 Error_Msg_NE ("\in instantiation of & declared#", 10585 Instantiation_Node, Scope (A_Gen_Obj)); 10586 10587 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 10588 10589 -- Create dummy constant declaration so that instance can be 10590 -- analyzed, to minimize cascaded visibility errors. 10591 10592 if Present (Subt_Mark) then 10593 Def := Subt_Mark; 10594 else pragma Assert (Present (Acc_Def)); 10595 Def := Acc_Def; 10596 end if; 10597 10598 Decl_Node := 10599 Make_Object_Declaration (Loc, 10600 Defining_Identifier => New_Copy (Gen_Obj), 10601 Constant_Present => True, 10602 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 10603 Object_Definition => New_Copy (Def), 10604 Expression => 10605 Make_Attribute_Reference (Sloc (Gen_Obj), 10606 Attribute_Name => Name_First, 10607 Prefix => New_Copy (Def))); 10608 10609 Append (Decl_Node, List); 10610 10611 else 10612 Abandon_Instantiation (Instantiation_Node); 10613 end if; 10614 end if; 10615 end if; 10616 10617 if Nkind (Actual) in N_Has_Entity then 10618 Actual_Decl := Parent (Entity (Actual)); 10619 end if; 10620 10621 -- Ada 2005 (AI-423): For a formal object declaration with a null 10622 -- exclusion or an access definition that has a null exclusion: If the 10623 -- actual matching the formal object declaration denotes a generic 10624 -- formal object of another generic unit G, and the instantiation 10625 -- containing the actual occurs within the body of G or within the body 10626 -- of a generic unit declared within the declarative region of G, then 10627 -- the declaration of the formal object of G must have a null exclusion. 10628 -- Otherwise, the subtype of the actual matching the formal object 10629 -- declaration shall exclude null. 10630 10631 if Ada_Version >= Ada_2005 10632 and then Present (Actual_Decl) 10633 and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 10634 N_Object_Declaration) 10635 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 10636 and then not Has_Null_Exclusion (Actual_Decl) 10637 and then Has_Null_Exclusion (Analyzed_Formal) 10638 then 10639 Error_Msg_Sloc := Sloc (Analyzed_Formal); 10640 Error_Msg_N 10641 ("actual must exclude null to match generic formal#", Actual); 10642 end if; 10643 10644 -- An effectively volatile object cannot be used as an actual in a 10645 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is 10646 -- relevant only when SPARK_Mode is on as it is not a standard Ada 10647 -- legality rule. 10648 10649 if SPARK_Mode = On 10650 and then Present (Actual) 10651 and then Is_Effectively_Volatile_Object (Actual) 10652 then 10653 Error_Msg_N 10654 ("volatile object cannot act as actual in generic instantiation", 10655 Actual); 10656 end if; 10657 10658 return List; 10659 end Instantiate_Object; 10660 10661 ------------------------------ 10662 -- Instantiate_Package_Body -- 10663 ------------------------------ 10664 10665 procedure Instantiate_Package_Body 10666 (Body_Info : Pending_Body_Info; 10667 Inlined_Body : Boolean := False; 10668 Body_Optional : Boolean := False) 10669 is 10670 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 10671 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 10672 Loc : constant Source_Ptr := Sloc (Inst_Node); 10673 10674 Gen_Id : constant Node_Id := Name (Inst_Node); 10675 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 10676 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 10677 Act_Spec : constant Node_Id := Specification (Act_Decl); 10678 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); 10679 10680 Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; 10681 Save_Style_Check : constant Boolean := Style_Check; 10682 10683 Act_Body : Node_Id; 10684 Act_Body_Id : Entity_Id; 10685 Act_Body_Name : Node_Id; 10686 Gen_Body : Node_Id; 10687 Gen_Body_Id : Node_Id; 10688 Par_Ent : Entity_Id := Empty; 10689 Par_Vis : Boolean := False; 10690 10691 Parent_Installed : Boolean := False; 10692 10693 Vis_Prims_List : Elist_Id := No_Elist; 10694 -- List of primitives made temporarily visible in the instantiation 10695 -- to match the visibility of the formal type 10696 10697 procedure Check_Initialized_Types; 10698 -- In a generic package body, an entity of a generic private type may 10699 -- appear uninitialized. This is suspicious, unless the actual is a 10700 -- fully initialized type. 10701 10702 ----------------------------- 10703 -- Check_Initialized_Types -- 10704 ----------------------------- 10705 10706 procedure Check_Initialized_Types is 10707 Decl : Node_Id; 10708 Formal : Entity_Id; 10709 Actual : Entity_Id; 10710 Uninit_Var : Entity_Id; 10711 10712 begin 10713 Decl := First (Generic_Formal_Declarations (Gen_Decl)); 10714 while Present (Decl) loop 10715 Uninit_Var := Empty; 10716 10717 if Nkind (Decl) = N_Private_Extension_Declaration then 10718 Uninit_Var := Uninitialized_Variable (Decl); 10719 10720 elsif Nkind (Decl) = N_Formal_Type_Declaration 10721 and then Nkind (Formal_Type_Definition (Decl)) = 10722 N_Formal_Private_Type_Definition 10723 then 10724 Uninit_Var := 10725 Uninitialized_Variable (Formal_Type_Definition (Decl)); 10726 end if; 10727 10728 if Present (Uninit_Var) then 10729 Formal := Defining_Identifier (Decl); 10730 Actual := First_Entity (Act_Decl_Id); 10731 10732 -- For each formal there is a subtype declaration that renames 10733 -- the actual and has the same name as the formal. Locate the 10734 -- formal for warning message about uninitialized variables 10735 -- in the generic, for which the actual type should be a fully 10736 -- initialized type. 10737 10738 while Present (Actual) loop 10739 exit when Ekind (Actual) = E_Package 10740 and then Present (Renamed_Object (Actual)); 10741 10742 if Chars (Actual) = Chars (Formal) 10743 and then not Is_Scalar_Type (Actual) 10744 and then not Is_Fully_Initialized_Type (Actual) 10745 and then Warn_On_No_Value_Assigned 10746 then 10747 Error_Msg_Node_2 := Formal; 10748 Error_Msg_NE 10749 ("generic unit has uninitialized variable& of " 10750 & "formal private type &?v?", Actual, Uninit_Var); 10751 Error_Msg_NE 10752 ("actual type for& should be fully initialized type?v?", 10753 Actual, Formal); 10754 exit; 10755 end if; 10756 10757 Next_Entity (Actual); 10758 end loop; 10759 end if; 10760 10761 Next (Decl); 10762 end loop; 10763 end Check_Initialized_Types; 10764 10765 -- Start of processing for Instantiate_Package_Body 10766 10767 begin 10768 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10769 10770 -- The instance body may already have been processed, as the parent of 10771 -- another instance that is inlined (Load_Parent_Of_Generic). 10772 10773 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 10774 return; 10775 end if; 10776 10777 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 10778 10779 -- Re-establish the state of information on which checks are suppressed. 10780 -- This information was set in Body_Info at the point of instantiation, 10781 -- and now we restore it so that the instance is compiled using the 10782 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 10783 10784 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 10785 Scope_Suppress := Body_Info.Scope_Suppress; 10786 Opt.Ada_Version := Body_Info.Version; 10787 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 10788 Restore_Warnings (Body_Info.Warnings); 10789 Opt.SPARK_Mode := Body_Info.SPARK_Mode; 10790 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma; 10791 10792 if No (Gen_Body_Id) then 10793 10794 -- Do not look for parent of generic body if none is required. 10795 -- This may happen when the routine is called as part of the 10796 -- Pending_Instantiations processing, when nested instances 10797 -- may precede the one generated from the main unit. 10798 10799 if not Unit_Requires_Body (Defining_Entity (Gen_Decl)) 10800 and then Body_Optional 10801 then 10802 return; 10803 else 10804 Load_Parent_Of_Generic 10805 (Inst_Node, Specification (Gen_Decl), Body_Optional); 10806 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10807 end if; 10808 end if; 10809 10810 -- Establish global variable for sloc adjustment and for error recovery 10811 -- In the case of an instance body for an instantiation with actuals 10812 -- from a limited view, the instance body is placed at the beginning 10813 -- of the enclosing package body: use the body entity as the source 10814 -- location for nodes of the instance body. 10815 10816 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then 10817 declare 10818 Scop : constant Entity_Id := Scope (Act_Decl_Id); 10819 Body_Id : constant Node_Id := 10820 Corresponding_Body (Unit_Declaration_Node (Scop)); 10821 10822 begin 10823 Instantiation_Node := Body_Id; 10824 end; 10825 else 10826 Instantiation_Node := Inst_Node; 10827 end if; 10828 10829 if Present (Gen_Body_Id) then 10830 Save_Env (Gen_Unit, Act_Decl_Id); 10831 Style_Check := False; 10832 10833 -- If the context of the instance is subject to SPARK_Mode "off" or 10834 -- the annotation is altogether missing, set the global flag which 10835 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 10836 -- the instance. 10837 10838 if SPARK_Mode /= On then 10839 Ignore_Pragma_SPARK_Mode := True; 10840 end if; 10841 10842 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 10843 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 10844 10845 Create_Instantiation_Source 10846 (Inst_Node, Gen_Body_Id, False, S_Adjustment); 10847 10848 Act_Body := 10849 Copy_Generic_Node 10850 (Original_Node (Gen_Body), Empty, Instantiating => True); 10851 10852 -- Create proper (possibly qualified) defining name for the body, to 10853 -- correspond to the one in the spec. 10854 10855 Act_Body_Id := 10856 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 10857 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 10858 10859 -- Some attributes of spec entity are not inherited by body entity 10860 10861 Set_Handler_Records (Act_Body_Id, No_List); 10862 10863 if Nkind (Defining_Unit_Name (Act_Spec)) = 10864 N_Defining_Program_Unit_Name 10865 then 10866 Act_Body_Name := 10867 Make_Defining_Program_Unit_Name (Loc, 10868 Name => 10869 New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 10870 Defining_Identifier => Act_Body_Id); 10871 else 10872 Act_Body_Name := Act_Body_Id; 10873 end if; 10874 10875 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 10876 10877 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 10878 Check_Generic_Actuals (Act_Decl_Id, False); 10879 Check_Initialized_Types; 10880 10881 -- Install primitives hidden at the point of the instantiation but 10882 -- visible when processing the generic formals 10883 10884 declare 10885 E : Entity_Id; 10886 10887 begin 10888 E := First_Entity (Act_Decl_Id); 10889 while Present (E) loop 10890 if Is_Type (E) 10891 and then Is_Generic_Actual_Type (E) 10892 and then Is_Tagged_Type (E) 10893 then 10894 Install_Hidden_Primitives 10895 (Prims_List => Vis_Prims_List, 10896 Gen_T => Generic_Parent_Type (Parent (E)), 10897 Act_T => E); 10898 end if; 10899 10900 Next_Entity (E); 10901 end loop; 10902 end; 10903 10904 -- If it is a child unit, make the parent instance (which is an 10905 -- instance of the parent of the generic) visible. The parent 10906 -- instance is the prefix of the name of the generic unit. 10907 10908 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 10909 and then Nkind (Gen_Id) = N_Expanded_Name 10910 then 10911 Par_Ent := Entity (Prefix (Gen_Id)); 10912 Par_Vis := Is_Immediately_Visible (Par_Ent); 10913 Install_Parent (Par_Ent, In_Body => True); 10914 Parent_Installed := True; 10915 10916 elsif Is_Child_Unit (Gen_Unit) then 10917 Par_Ent := Scope (Gen_Unit); 10918 Par_Vis := Is_Immediately_Visible (Par_Ent); 10919 Install_Parent (Par_Ent, In_Body => True); 10920 Parent_Installed := True; 10921 end if; 10922 10923 -- If the instantiation is a library unit, and this is the main unit, 10924 -- then build the resulting compilation unit nodes for the instance. 10925 -- If this is a compilation unit but it is not the main unit, then it 10926 -- is the body of a unit in the context, that is being compiled 10927 -- because it is encloses some inlined unit or another generic unit 10928 -- being instantiated. In that case, this body is not part of the 10929 -- current compilation, and is not attached to the tree, but its 10930 -- parent must be set for analysis. 10931 10932 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10933 10934 -- Replace instance node with body of instance, and create new 10935 -- node for corresponding instance declaration. 10936 10937 Build_Instance_Compilation_Unit_Nodes 10938 (Inst_Node, Act_Body, Act_Decl); 10939 Analyze (Inst_Node); 10940 10941 if Parent (Inst_Node) = Cunit (Main_Unit) then 10942 10943 -- If the instance is a child unit itself, then set the scope 10944 -- of the expanded body to be the parent of the instantiation 10945 -- (ensuring that the fully qualified name will be generated 10946 -- for the elaboration subprogram). 10947 10948 if Nkind (Defining_Unit_Name (Act_Spec)) = 10949 N_Defining_Program_Unit_Name 10950 then 10951 Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 10952 end if; 10953 end if; 10954 10955 -- Case where instantiation is not a library unit 10956 10957 else 10958 -- If this is an early instantiation, i.e. appears textually 10959 -- before the corresponding body and must be elaborated first, 10960 -- indicate that the body instance is to be delayed. 10961 10962 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 10963 10964 -- Now analyze the body. We turn off all checks if this is an 10965 -- internal unit, since there is no reason to have checks on for 10966 -- any predefined run-time library code. All such code is designed 10967 -- to be compiled with checks off. 10968 10969 -- Note that we do NOT apply this criterion to children of GNAT 10970 -- The latter units must suppress checks explicitly if needed. 10971 10972 if Is_Predefined_File_Name 10973 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 10974 then 10975 Analyze (Act_Body, Suppress => All_Checks); 10976 else 10977 Analyze (Act_Body); 10978 end if; 10979 end if; 10980 10981 Inherit_Context (Gen_Body, Inst_Node); 10982 10983 -- Remove the parent instances if they have been placed on the scope 10984 -- stack to compile the body. 10985 10986 if Parent_Installed then 10987 Remove_Parent (In_Body => True); 10988 10989 -- Restore the previous visibility of the parent 10990 10991 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 10992 end if; 10993 10994 Restore_Hidden_Primitives (Vis_Prims_List); 10995 Restore_Private_Views (Act_Decl_Id); 10996 10997 -- Remove the current unit from visibility if this is an instance 10998 -- that is not elaborated on the fly for inlining purposes. 10999 11000 if not Inlined_Body then 11001 Set_Is_Immediately_Visible (Act_Decl_Id, False); 11002 end if; 11003 11004 Restore_Env; 11005 Ignore_Pragma_SPARK_Mode := Save_IPSM; 11006 Style_Check := Save_Style_Check; 11007 11008 -- If we have no body, and the unit requires a body, then complain. This 11009 -- complaint is suppressed if we have detected other errors (since a 11010 -- common reason for missing the body is that it had errors). 11011 -- In CodePeer mode, a warning has been emitted already, no need for 11012 -- further messages. 11013 11014 elsif Unit_Requires_Body (Gen_Unit) 11015 and then not Body_Optional 11016 then 11017 if CodePeer_Mode then 11018 null; 11019 11020 elsif Serious_Errors_Detected = 0 then 11021 Error_Msg_NE 11022 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 11023 11024 -- Don't attempt to perform any cleanup actions if some other error 11025 -- was already detected, since this can cause blowups. 11026 11027 else 11028 return; 11029 end if; 11030 11031 -- Case of package that does not need a body 11032 11033 else 11034 -- If the instantiation of the declaration is a library unit, rewrite 11035 -- the original package instantiation as a package declaration in the 11036 -- compilation unit node. 11037 11038 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11039 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 11040 Rewrite (Inst_Node, Act_Decl); 11041 11042 -- Generate elaboration entity, in case spec has elaboration code. 11043 -- This cannot be done when the instance is analyzed, because it 11044 -- is not known yet whether the body exists. 11045 11046 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 11047 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 11048 11049 -- If the instantiation is not a library unit, then append the 11050 -- declaration to the list of implicitly generated entities, unless 11051 -- it is already a list member which means that it was already 11052 -- processed 11053 11054 elsif not Is_List_Member (Act_Decl) then 11055 Mark_Rewrite_Insertion (Act_Decl); 11056 Insert_Before (Inst_Node, Act_Decl); 11057 end if; 11058 end if; 11059 11060 Expander_Mode_Restore; 11061 end Instantiate_Package_Body; 11062 11063 --------------------------------- 11064 -- Instantiate_Subprogram_Body -- 11065 --------------------------------- 11066 11067 procedure Instantiate_Subprogram_Body 11068 (Body_Info : Pending_Body_Info; 11069 Body_Optional : Boolean := False) 11070 is 11071 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11072 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11073 Loc : constant Source_Ptr := Sloc (Inst_Node); 11074 Gen_Id : constant Node_Id := Name (Inst_Node); 11075 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11076 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11077 Act_Decl_Id : constant Entity_Id := 11078 Defining_Unit_Name (Specification (Act_Decl)); 11079 Pack_Id : constant Entity_Id := 11080 Defining_Unit_Name (Parent (Act_Decl)); 11081 11082 Saved_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; 11083 Saved_Style_Check : constant Boolean := Style_Check; 11084 Saved_Warnings : constant Warning_Record := Save_Warnings; 11085 11086 Act_Body : Node_Id; 11087 Act_Body_Id : Entity_Id; 11088 Gen_Body : Node_Id; 11089 Gen_Body_Id : Node_Id; 11090 Pack_Body : Node_Id; 11091 Par_Ent : Entity_Id := Empty; 11092 Par_Vis : Boolean := False; 11093 Ret_Expr : Node_Id; 11094 11095 Parent_Installed : Boolean := False; 11096 11097 begin 11098 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11099 11100 -- Subprogram body may have been created already because of an inline 11101 -- pragma, or because of multiple elaborations of the enclosing package 11102 -- when several instances of the subprogram appear in the main unit. 11103 11104 if Present (Corresponding_Body (Act_Decl)) then 11105 return; 11106 end if; 11107 11108 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11109 11110 -- Re-establish the state of information on which checks are suppressed. 11111 -- This information was set in Body_Info at the point of instantiation, 11112 -- and now we restore it so that the instance is compiled using the 11113 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11114 11115 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11116 Scope_Suppress := Body_Info.Scope_Suppress; 11117 Opt.Ada_Version := Body_Info.Version; 11118 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 11119 Restore_Warnings (Body_Info.Warnings); 11120 Opt.SPARK_Mode := Body_Info.SPARK_Mode; 11121 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma; 11122 11123 if No (Gen_Body_Id) then 11124 11125 -- For imported generic subprogram, no body to compile, complete 11126 -- the spec entity appropriately. 11127 11128 if Is_Imported (Gen_Unit) then 11129 Set_Is_Imported (Act_Decl_Id); 11130 Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit)); 11131 Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); 11132 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 11133 Set_Has_Completion (Act_Decl_Id); 11134 return; 11135 11136 -- For other cases, compile the body 11137 11138 else 11139 Load_Parent_Of_Generic 11140 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11141 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11142 end if; 11143 end if; 11144 11145 Instantiation_Node := Inst_Node; 11146 11147 if Present (Gen_Body_Id) then 11148 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11149 11150 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 11151 11152 -- Either body is not present, or context is non-expanding, as 11153 -- when compiling a subunit. Mark the instance as completed, and 11154 -- diagnose a missing body when needed. 11155 11156 if Expander_Active 11157 and then Operating_Mode = Generate_Code 11158 then 11159 Error_Msg_N 11160 ("missing proper body for instantiation", Gen_Body); 11161 end if; 11162 11163 Set_Has_Completion (Act_Decl_Id); 11164 return; 11165 end if; 11166 11167 Save_Env (Gen_Unit, Act_Decl_Id); 11168 Style_Check := False; 11169 11170 -- If the context of the instance is subject to SPARK_Mode "off" or 11171 -- the annotation is altogether missing, set the global flag which 11172 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 11173 -- the instance. 11174 11175 if SPARK_Mode /= On then 11176 Ignore_Pragma_SPARK_Mode := True; 11177 end if; 11178 11179 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11180 Create_Instantiation_Source 11181 (Inst_Node, 11182 Gen_Body_Id, 11183 False, 11184 S_Adjustment); 11185 11186 Act_Body := 11187 Copy_Generic_Node 11188 (Original_Node (Gen_Body), Empty, Instantiating => True); 11189 11190 -- Create proper defining name for the body, to correspond to the one 11191 -- in the spec. 11192 11193 Act_Body_Id := 11194 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11195 11196 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11197 Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); 11198 11199 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11200 Set_Has_Completion (Act_Decl_Id); 11201 Check_Generic_Actuals (Pack_Id, False); 11202 11203 -- Generate a reference to link the visible subprogram instance to 11204 -- the generic body, which for navigation purposes is the only 11205 -- available source for the instance. 11206 11207 Generate_Reference 11208 (Related_Instance (Pack_Id), 11209 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 11210 11211 -- If it is a child unit, make the parent instance (which is an 11212 -- instance of the parent of the generic) visible. The parent 11213 -- instance is the prefix of the name of the generic unit. 11214 11215 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11216 and then Nkind (Gen_Id) = N_Expanded_Name 11217 then 11218 Par_Ent := Entity (Prefix (Gen_Id)); 11219 Par_Vis := Is_Immediately_Visible (Par_Ent); 11220 Install_Parent (Par_Ent, In_Body => True); 11221 Parent_Installed := True; 11222 11223 elsif Is_Child_Unit (Gen_Unit) then 11224 Par_Ent := Scope (Gen_Unit); 11225 Par_Vis := Is_Immediately_Visible (Par_Ent); 11226 Install_Parent (Par_Ent, In_Body => True); 11227 Parent_Installed := True; 11228 end if; 11229 11230 -- Subprogram body is placed in the body of wrapper package, 11231 -- whose spec contains the subprogram declaration as well as 11232 -- the renaming declarations for the generic parameters. 11233 11234 Pack_Body := 11235 Make_Package_Body (Loc, 11236 Defining_Unit_Name => New_Copy (Pack_Id), 11237 Declarations => New_List (Act_Body)); 11238 11239 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11240 11241 -- If the instantiation is a library unit, then build resulting 11242 -- compilation unit nodes for the instance. The declaration of 11243 -- the enclosing package is the grandparent of the subprogram 11244 -- declaration. First replace the instantiation node as the unit 11245 -- of the corresponding compilation. 11246 11247 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11248 if Parent (Inst_Node) = Cunit (Main_Unit) then 11249 Set_Unit (Parent (Inst_Node), Inst_Node); 11250 Build_Instance_Compilation_Unit_Nodes 11251 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 11252 Analyze (Inst_Node); 11253 else 11254 Set_Parent (Pack_Body, Parent (Inst_Node)); 11255 Analyze (Pack_Body); 11256 end if; 11257 11258 else 11259 Insert_Before (Inst_Node, Pack_Body); 11260 Mark_Rewrite_Insertion (Pack_Body); 11261 Analyze (Pack_Body); 11262 11263 if Expander_Active then 11264 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 11265 end if; 11266 end if; 11267 11268 Inherit_Context (Gen_Body, Inst_Node); 11269 11270 Restore_Private_Views (Pack_Id, False); 11271 11272 if Parent_Installed then 11273 Remove_Parent (In_Body => True); 11274 11275 -- Restore the previous visibility of the parent 11276 11277 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11278 end if; 11279 11280 Restore_Env; 11281 Ignore_Pragma_SPARK_Mode := Saved_IPSM; 11282 Style_Check := Saved_Style_Check; 11283 Restore_Warnings (Saved_Warnings); 11284 11285 -- Body not found. Error was emitted already. If there were no previous 11286 -- errors, this may be an instance whose scope is a premature instance. 11287 -- In that case we must insure that the (legal) program does raise 11288 -- program error if executed. We generate a subprogram body for this 11289 -- purpose. See DEC ac30vso. 11290 11291 -- Should not reference proprietary DEC tests in comments ??? 11292 11293 elsif Serious_Errors_Detected = 0 11294 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 11295 then 11296 if Body_Optional then 11297 return; 11298 11299 elsif Ekind (Act_Decl_Id) = E_Procedure then 11300 Act_Body := 11301 Make_Subprogram_Body (Loc, 11302 Specification => 11303 Make_Procedure_Specification (Loc, 11304 Defining_Unit_Name => 11305 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11306 Parameter_Specifications => 11307 New_Copy_List 11308 (Parameter_Specifications (Parent (Act_Decl_Id)))), 11309 11310 Declarations => Empty_List, 11311 Handled_Statement_Sequence => 11312 Make_Handled_Sequence_Of_Statements (Loc, 11313 Statements => 11314 New_List ( 11315 Make_Raise_Program_Error (Loc, 11316 Reason => 11317 PE_Access_Before_Elaboration)))); 11318 11319 else 11320 Ret_Expr := 11321 Make_Raise_Program_Error (Loc, 11322 Reason => PE_Access_Before_Elaboration); 11323 11324 Set_Etype (Ret_Expr, (Etype (Act_Decl_Id))); 11325 Set_Analyzed (Ret_Expr); 11326 11327 Act_Body := 11328 Make_Subprogram_Body (Loc, 11329 Specification => 11330 Make_Function_Specification (Loc, 11331 Defining_Unit_Name => 11332 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11333 Parameter_Specifications => 11334 New_Copy_List 11335 (Parameter_Specifications (Parent (Act_Decl_Id))), 11336 Result_Definition => 11337 New_Occurrence_Of (Etype (Act_Decl_Id), Loc)), 11338 11339 Declarations => Empty_List, 11340 Handled_Statement_Sequence => 11341 Make_Handled_Sequence_Of_Statements (Loc, 11342 Statements => 11343 New_List 11344 (Make_Simple_Return_Statement (Loc, Ret_Expr)))); 11345 end if; 11346 11347 Pack_Body := 11348 Make_Package_Body (Loc, 11349 Defining_Unit_Name => New_Copy (Pack_Id), 11350 Declarations => New_List (Act_Body)); 11351 11352 Insert_After (Inst_Node, Pack_Body); 11353 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11354 Analyze (Pack_Body); 11355 end if; 11356 11357 Expander_Mode_Restore; 11358 end Instantiate_Subprogram_Body; 11359 11360 ---------------------- 11361 -- Instantiate_Type -- 11362 ---------------------- 11363 11364 function Instantiate_Type 11365 (Formal : Node_Id; 11366 Actual : Node_Id; 11367 Analyzed_Formal : Node_Id; 11368 Actual_Decls : List_Id) return List_Id 11369 is 11370 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 11371 A_Gen_T : constant Entity_Id := 11372 Defining_Identifier (Analyzed_Formal); 11373 Ancestor : Entity_Id := Empty; 11374 Def : constant Node_Id := Formal_Type_Definition (Formal); 11375 Act_T : Entity_Id; 11376 Decl_Node : Node_Id; 11377 Decl_Nodes : List_Id; 11378 Loc : Source_Ptr; 11379 Subt : Entity_Id; 11380 11381 procedure Diagnose_Predicated_Actual; 11382 -- There are a number of constructs in which a discrete type with 11383 -- predicates is illegal, e.g. as an index in an array type declaration. 11384 -- If a generic type is used is such a construct in a generic package 11385 -- declaration, it carries the flag No_Predicate_On_Actual. it is part 11386 -- of the generic contract that the actual cannot have predicates. 11387 11388 procedure Validate_Array_Type_Instance; 11389 procedure Validate_Access_Subprogram_Instance; 11390 procedure Validate_Access_Type_Instance; 11391 procedure Validate_Derived_Type_Instance; 11392 procedure Validate_Derived_Interface_Type_Instance; 11393 procedure Validate_Discriminated_Formal_Type; 11394 procedure Validate_Interface_Type_Instance; 11395 procedure Validate_Private_Type_Instance; 11396 procedure Validate_Incomplete_Type_Instance; 11397 -- These procedures perform validation tests for the named case. 11398 -- Validate_Discriminated_Formal_Type is shared by formal private 11399 -- types and Ada 2012 formal incomplete types. 11400 11401 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 11402 -- Check that base types are the same and that the subtypes match 11403 -- statically. Used in several of the above. 11404 11405 --------------------------------- 11406 -- Diagnose_Predicated_Actual -- 11407 --------------------------------- 11408 11409 procedure Diagnose_Predicated_Actual is 11410 begin 11411 if No_Predicate_On_Actual (A_Gen_T) 11412 and then Has_Predicates (Act_T) 11413 then 11414 Error_Msg_NE 11415 ("actual for& cannot be a type with predicate", 11416 Instantiation_Node, A_Gen_T); 11417 11418 elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) 11419 and then Has_Predicates (Act_T) 11420 and then not Has_Static_Predicate_Aspect (Act_T) 11421 then 11422 Error_Msg_NE 11423 ("actual for& cannot be a type with a dynamic predicate", 11424 Instantiation_Node, A_Gen_T); 11425 end if; 11426 end Diagnose_Predicated_Actual; 11427 11428 -------------------- 11429 -- Subtypes_Match -- 11430 -------------------- 11431 11432 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 11433 T : constant Entity_Id := Get_Instance_Of (Gen_T); 11434 11435 begin 11436 -- Some detailed comments would be useful here ??? 11437 11438 return ((Base_Type (T) = Act_T 11439 or else Base_Type (T) = Base_Type (Act_T)) 11440 and then Subtypes_Statically_Match (T, Act_T)) 11441 11442 or else (Is_Class_Wide_Type (Gen_T) 11443 and then Is_Class_Wide_Type (Act_T) 11444 and then Subtypes_Match 11445 (Get_Instance_Of (Root_Type (Gen_T)), 11446 Root_Type (Act_T))) 11447 11448 or else 11449 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 11450 E_Anonymous_Access_Type) 11451 and then Ekind (Act_T) = Ekind (Gen_T) 11452 and then Subtypes_Statically_Match 11453 (Designated_Type (Gen_T), Designated_Type (Act_T))); 11454 end Subtypes_Match; 11455 11456 ----------------------------------------- 11457 -- Validate_Access_Subprogram_Instance -- 11458 ----------------------------------------- 11459 11460 procedure Validate_Access_Subprogram_Instance is 11461 begin 11462 if not Is_Access_Type (Act_T) 11463 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 11464 then 11465 Error_Msg_NE 11466 ("expect access type in instantiation of &", Actual, Gen_T); 11467 Abandon_Instantiation (Actual); 11468 end if; 11469 11470 -- According to AI05-288, actuals for access_to_subprograms must be 11471 -- subtype conformant with the generic formal. Previous to AI05-288 11472 -- only mode conformance was required. 11473 11474 -- This is a binding interpretation that applies to previous versions 11475 -- of the language, no need to maintain previous weaker checks. 11476 11477 Check_Subtype_Conformant 11478 (Designated_Type (Act_T), 11479 Designated_Type (A_Gen_T), 11480 Actual, 11481 Get_Inst => True); 11482 11483 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 11484 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 11485 Error_Msg_NE 11486 ("protected access type not allowed for formal &", 11487 Actual, Gen_T); 11488 end if; 11489 11490 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 11491 Error_Msg_NE 11492 ("expect protected access type for formal &", 11493 Actual, Gen_T); 11494 end if; 11495 11496 -- If the formal has a specified convention (which in most cases 11497 -- will be StdCall) verify that the actual has the same convention. 11498 11499 if Has_Convention_Pragma (A_Gen_T) 11500 and then Convention (A_Gen_T) /= Convention (Act_T) 11501 then 11502 Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T)); 11503 Error_Msg_NE 11504 ("actual for formal & must have convention %", Actual, Gen_T); 11505 end if; 11506 end Validate_Access_Subprogram_Instance; 11507 11508 ----------------------------------- 11509 -- Validate_Access_Type_Instance -- 11510 ----------------------------------- 11511 11512 procedure Validate_Access_Type_Instance is 11513 Desig_Type : constant Entity_Id := 11514 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 11515 Desig_Act : Entity_Id; 11516 11517 begin 11518 if not Is_Access_Type (Act_T) then 11519 Error_Msg_NE 11520 ("expect access type in instantiation of &", Actual, Gen_T); 11521 Abandon_Instantiation (Actual); 11522 end if; 11523 11524 if Is_Access_Constant (A_Gen_T) then 11525 if not Is_Access_Constant (Act_T) then 11526 Error_Msg_N 11527 ("actual type must be access-to-constant type", Actual); 11528 Abandon_Instantiation (Actual); 11529 end if; 11530 else 11531 if Is_Access_Constant (Act_T) then 11532 Error_Msg_N 11533 ("actual type must be access-to-variable type", Actual); 11534 Abandon_Instantiation (Actual); 11535 11536 elsif Ekind (A_Gen_T) = E_General_Access_Type 11537 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 11538 then 11539 Error_Msg_N -- CODEFIX 11540 ("actual must be general access type!", Actual); 11541 Error_Msg_NE -- CODEFIX 11542 ("add ALL to }!", Actual, Act_T); 11543 Abandon_Instantiation (Actual); 11544 end if; 11545 end if; 11546 11547 -- The designated subtypes, that is to say the subtypes introduced 11548 -- by an access type declaration (and not by a subtype declaration) 11549 -- must match. 11550 11551 Desig_Act := Designated_Type (Base_Type (Act_T)); 11552 11553 -- The designated type may have been introduced through a limited_ 11554 -- with clause, in which case retrieve the non-limited view. This 11555 -- applies to incomplete types as well as to class-wide types. 11556 11557 if From_Limited_With (Desig_Act) then 11558 Desig_Act := Available_View (Desig_Act); 11559 end if; 11560 11561 if not Subtypes_Match (Desig_Type, Desig_Act) then 11562 Error_Msg_NE 11563 ("designated type of actual does not match that of formal &", 11564 Actual, Gen_T); 11565 11566 if not Predicates_Match (Desig_Type, Desig_Act) then 11567 Error_Msg_N ("\predicates do not match", Actual); 11568 end if; 11569 11570 Abandon_Instantiation (Actual); 11571 11572 elsif Is_Access_Type (Designated_Type (Act_T)) 11573 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 11574 /= 11575 Is_Constrained (Designated_Type (Desig_Type)) 11576 then 11577 Error_Msg_NE 11578 ("designated type of actual does not match that of formal &", 11579 Actual, Gen_T); 11580 11581 if not Predicates_Match (Desig_Type, Desig_Act) then 11582 Error_Msg_N ("\predicates do not match", Actual); 11583 end if; 11584 11585 Abandon_Instantiation (Actual); 11586 end if; 11587 11588 -- Ada 2005: null-exclusion indicators of the two types must agree 11589 11590 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 11591 Error_Msg_NE 11592 ("non null exclusion of actual and formal & do not match", 11593 Actual, Gen_T); 11594 end if; 11595 end Validate_Access_Type_Instance; 11596 11597 ---------------------------------- 11598 -- Validate_Array_Type_Instance -- 11599 ---------------------------------- 11600 11601 procedure Validate_Array_Type_Instance is 11602 I1 : Node_Id; 11603 I2 : Node_Id; 11604 T2 : Entity_Id; 11605 11606 function Formal_Dimensions return Int; 11607 -- Count number of dimensions in array type formal 11608 11609 ----------------------- 11610 -- Formal_Dimensions -- 11611 ----------------------- 11612 11613 function Formal_Dimensions return Int is 11614 Num : Int := 0; 11615 Index : Node_Id; 11616 11617 begin 11618 if Nkind (Def) = N_Constrained_Array_Definition then 11619 Index := First (Discrete_Subtype_Definitions (Def)); 11620 else 11621 Index := First (Subtype_Marks (Def)); 11622 end if; 11623 11624 while Present (Index) loop 11625 Num := Num + 1; 11626 Next_Index (Index); 11627 end loop; 11628 11629 return Num; 11630 end Formal_Dimensions; 11631 11632 -- Start of processing for Validate_Array_Type_Instance 11633 11634 begin 11635 if not Is_Array_Type (Act_T) then 11636 Error_Msg_NE 11637 ("expect array type in instantiation of &", Actual, Gen_T); 11638 Abandon_Instantiation (Actual); 11639 11640 elsif Nkind (Def) = N_Constrained_Array_Definition then 11641 if not (Is_Constrained (Act_T)) then 11642 Error_Msg_NE 11643 ("expect constrained array in instantiation of &", 11644 Actual, Gen_T); 11645 Abandon_Instantiation (Actual); 11646 end if; 11647 11648 else 11649 if Is_Constrained (Act_T) then 11650 Error_Msg_NE 11651 ("expect unconstrained array in instantiation of &", 11652 Actual, Gen_T); 11653 Abandon_Instantiation (Actual); 11654 end if; 11655 end if; 11656 11657 if Formal_Dimensions /= Number_Dimensions (Act_T) then 11658 Error_Msg_NE 11659 ("dimensions of actual do not match formal &", Actual, Gen_T); 11660 Abandon_Instantiation (Actual); 11661 end if; 11662 11663 I1 := First_Index (A_Gen_T); 11664 I2 := First_Index (Act_T); 11665 for J in 1 .. Formal_Dimensions loop 11666 11667 -- If the indexes of the actual were given by a subtype_mark, 11668 -- the index was transformed into a range attribute. Retrieve 11669 -- the original type mark for checking. 11670 11671 if Is_Entity_Name (Original_Node (I2)) then 11672 T2 := Entity (Original_Node (I2)); 11673 else 11674 T2 := Etype (I2); 11675 end if; 11676 11677 if not Subtypes_Match 11678 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 11679 then 11680 Error_Msg_NE 11681 ("index types of actual do not match those of formal &", 11682 Actual, Gen_T); 11683 Abandon_Instantiation (Actual); 11684 end if; 11685 11686 Next_Index (I1); 11687 Next_Index (I2); 11688 end loop; 11689 11690 -- Check matching subtypes. Note that there are complex visibility 11691 -- issues when the generic is a child unit and some aspect of the 11692 -- generic type is declared in a parent unit of the generic. We do 11693 -- the test to handle this special case only after a direct check 11694 -- for static matching has failed. The case where both the component 11695 -- type and the array type are separate formals, and the component 11696 -- type is a private view may also require special checking in 11697 -- Subtypes_Match. 11698 11699 if Subtypes_Match 11700 (Component_Type (A_Gen_T), Component_Type (Act_T)) 11701 or else 11702 Subtypes_Match 11703 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 11704 Component_Type (Act_T)) 11705 then 11706 null; 11707 else 11708 Error_Msg_NE 11709 ("component subtype of actual does not match that of formal &", 11710 Actual, Gen_T); 11711 Abandon_Instantiation (Actual); 11712 end if; 11713 11714 if Has_Aliased_Components (A_Gen_T) 11715 and then not Has_Aliased_Components (Act_T) 11716 then 11717 Error_Msg_NE 11718 ("actual must have aliased components to match formal type &", 11719 Actual, Gen_T); 11720 end if; 11721 end Validate_Array_Type_Instance; 11722 11723 ----------------------------------------------- 11724 -- Validate_Derived_Interface_Type_Instance -- 11725 ----------------------------------------------- 11726 11727 procedure Validate_Derived_Interface_Type_Instance is 11728 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 11729 Elmt : Elmt_Id; 11730 11731 begin 11732 -- First apply interface instance checks 11733 11734 Validate_Interface_Type_Instance; 11735 11736 -- Verify that immediate parent interface is an ancestor of 11737 -- the actual. 11738 11739 if Present (Par) 11740 and then not Interface_Present_In_Ancestor (Act_T, Par) 11741 then 11742 Error_Msg_NE 11743 ("interface actual must include progenitor&", Actual, Par); 11744 end if; 11745 11746 -- Now verify that the actual includes all other ancestors of 11747 -- the formal. 11748 11749 Elmt := First_Elmt (Interfaces (A_Gen_T)); 11750 while Present (Elmt) loop 11751 if not Interface_Present_In_Ancestor 11752 (Act_T, Get_Instance_Of (Node (Elmt))) 11753 then 11754 Error_Msg_NE 11755 ("interface actual must include progenitor&", 11756 Actual, Node (Elmt)); 11757 end if; 11758 11759 Next_Elmt (Elmt); 11760 end loop; 11761 end Validate_Derived_Interface_Type_Instance; 11762 11763 ------------------------------------ 11764 -- Validate_Derived_Type_Instance -- 11765 ------------------------------------ 11766 11767 procedure Validate_Derived_Type_Instance is 11768 Actual_Discr : Entity_Id; 11769 Ancestor_Discr : Entity_Id; 11770 11771 begin 11772 -- If the parent type in the generic declaration is itself a previous 11773 -- formal type, then it is local to the generic and absent from the 11774 -- analyzed generic definition. In that case the ancestor is the 11775 -- instance of the formal (which must have been instantiated 11776 -- previously), unless the ancestor is itself a formal derived type. 11777 -- In this latter case (which is the subject of Corrigendum 8652/0038 11778 -- (AI-202) the ancestor of the formals is the ancestor of its 11779 -- parent. Otherwise, the analyzed generic carries the parent type. 11780 -- If the parent type is defined in a previous formal package, then 11781 -- the scope of that formal package is that of the generic type 11782 -- itself, and it has already been mapped into the corresponding type 11783 -- in the actual package. 11784 11785 -- Common case: parent type defined outside of the generic 11786 11787 if Is_Entity_Name (Subtype_Mark (Def)) 11788 and then Present (Entity (Subtype_Mark (Def))) 11789 then 11790 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 11791 11792 -- Check whether parent is defined in a previous formal package 11793 11794 elsif 11795 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 11796 then 11797 Ancestor := 11798 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 11799 11800 -- The type may be a local derivation, or a type extension of a 11801 -- previous formal, or of a formal of a parent package. 11802 11803 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 11804 or else 11805 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 11806 then 11807 -- Check whether the parent is another derived formal type in the 11808 -- same generic unit. 11809 11810 if Etype (A_Gen_T) /= A_Gen_T 11811 and then Is_Generic_Type (Etype (A_Gen_T)) 11812 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 11813 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 11814 then 11815 -- Locate ancestor of parent from the subtype declaration 11816 -- created for the actual. 11817 11818 declare 11819 Decl : Node_Id; 11820 11821 begin 11822 Decl := First (Actual_Decls); 11823 while Present (Decl) loop 11824 if Nkind (Decl) = N_Subtype_Declaration 11825 and then Chars (Defining_Identifier (Decl)) = 11826 Chars (Etype (A_Gen_T)) 11827 then 11828 Ancestor := Generic_Parent_Type (Decl); 11829 exit; 11830 else 11831 Next (Decl); 11832 end if; 11833 end loop; 11834 end; 11835 11836 pragma Assert (Present (Ancestor)); 11837 11838 -- The ancestor itself may be a previous formal that has been 11839 -- instantiated. 11840 11841 Ancestor := Get_Instance_Of (Ancestor); 11842 11843 else 11844 Ancestor := 11845 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 11846 end if; 11847 11848 -- Check whether parent is a previous formal of the current generic 11849 11850 elsif Is_Derived_Type (A_Gen_T) 11851 and then Is_Generic_Type (Etype (A_Gen_T)) 11852 and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T)) 11853 then 11854 Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T))); 11855 11856 -- An unusual case: the actual is a type declared in a parent unit, 11857 -- but is not a formal type so there is no instance_of for it. 11858 -- Retrieve it by analyzing the record extension. 11859 11860 elsif Is_Child_Unit (Scope (A_Gen_T)) 11861 and then In_Open_Scopes (Scope (Act_T)) 11862 and then Is_Generic_Instance (Scope (Act_T)) 11863 then 11864 Analyze (Subtype_Mark (Def)); 11865 Ancestor := Entity (Subtype_Mark (Def)); 11866 11867 else 11868 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 11869 end if; 11870 11871 -- If the formal derived type has pragma Preelaborable_Initialization 11872 -- then the actual type must have preelaborable initialization. 11873 11874 if Known_To_Have_Preelab_Init (A_Gen_T) 11875 and then not Has_Preelaborable_Initialization (Act_T) 11876 then 11877 Error_Msg_NE 11878 ("actual for & must have preelaborable initialization", 11879 Actual, Gen_T); 11880 end if; 11881 11882 -- Ada 2005 (AI-251) 11883 11884 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then 11885 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 11886 Error_Msg_NE 11887 ("(Ada 2005) expected type implementing & in instantiation", 11888 Actual, Ancestor); 11889 end if; 11890 11891 -- Finally verify that the (instance of) the ancestor is an ancestor 11892 -- of the actual. 11893 11894 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 11895 Error_Msg_NE 11896 ("expect type derived from & in instantiation", 11897 Actual, First_Subtype (Ancestor)); 11898 Abandon_Instantiation (Actual); 11899 end if; 11900 11901 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 11902 -- that the formal type declaration has been rewritten as a private 11903 -- extension. 11904 11905 if Ada_Version >= Ada_2005 11906 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 11907 and then Synchronized_Present (Parent (A_Gen_T)) 11908 then 11909 -- The actual must be a synchronized tagged type 11910 11911 if not Is_Tagged_Type (Act_T) then 11912 Error_Msg_N 11913 ("actual of synchronized type must be tagged", Actual); 11914 Abandon_Instantiation (Actual); 11915 11916 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 11917 and then Nkind (Type_Definition (Parent (Act_T))) = 11918 N_Derived_Type_Definition 11919 and then not Synchronized_Present 11920 (Type_Definition (Parent (Act_T))) 11921 then 11922 Error_Msg_N 11923 ("actual of synchronized type must be synchronized", Actual); 11924 Abandon_Instantiation (Actual); 11925 end if; 11926 end if; 11927 11928 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 11929 -- removes the second instance of the phrase "or allow pass by copy". 11930 11931 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then 11932 Error_Msg_N 11933 ("cannot have atomic actual type for non-atomic formal type", 11934 Actual); 11935 11936 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then 11937 Error_Msg_N 11938 ("cannot have volatile actual type for non-volatile formal type", 11939 Actual); 11940 end if; 11941 11942 -- It should not be necessary to check for unknown discriminants on 11943 -- Formal, but for some reason Has_Unknown_Discriminants is false for 11944 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This 11945 -- needs fixing. ??? 11946 11947 if Is_Definite_Subtype (A_Gen_T) 11948 and then not Unknown_Discriminants_Present (Formal) 11949 and then not Is_Definite_Subtype (Act_T) 11950 then 11951 Error_Msg_N ("actual subtype must be constrained", Actual); 11952 Abandon_Instantiation (Actual); 11953 end if; 11954 11955 if not Unknown_Discriminants_Present (Formal) then 11956 if Is_Constrained (Ancestor) then 11957 if not Is_Constrained (Act_T) then 11958 Error_Msg_N ("actual subtype must be constrained", Actual); 11959 Abandon_Instantiation (Actual); 11960 end if; 11961 11962 -- Ancestor is unconstrained, Check if generic formal and actual 11963 -- agree on constrainedness. The check only applies to array types 11964 -- and discriminated types. 11965 11966 elsif Is_Constrained (Act_T) then 11967 if Ekind (Ancestor) = E_Access_Type 11968 or else (not Is_Constrained (A_Gen_T) 11969 and then Is_Composite_Type (A_Gen_T)) 11970 then 11971 Error_Msg_N ("actual subtype must be unconstrained", Actual); 11972 Abandon_Instantiation (Actual); 11973 end if; 11974 11975 -- A class-wide type is only allowed if the formal has unknown 11976 -- discriminants. 11977 11978 elsif Is_Class_Wide_Type (Act_T) 11979 and then not Has_Unknown_Discriminants (Ancestor) 11980 then 11981 Error_Msg_NE 11982 ("actual for & cannot be a class-wide type", Actual, Gen_T); 11983 Abandon_Instantiation (Actual); 11984 11985 -- Otherwise, the formal and actual must have the same number 11986 -- of discriminants and each discriminant of the actual must 11987 -- correspond to a discriminant of the formal. 11988 11989 elsif Has_Discriminants (Act_T) 11990 and then not Has_Unknown_Discriminants (Act_T) 11991 and then Has_Discriminants (Ancestor) 11992 then 11993 Actual_Discr := First_Discriminant (Act_T); 11994 Ancestor_Discr := First_Discriminant (Ancestor); 11995 while Present (Actual_Discr) 11996 and then Present (Ancestor_Discr) 11997 loop 11998 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 11999 No (Corresponding_Discriminant (Actual_Discr)) 12000 then 12001 Error_Msg_NE 12002 ("discriminant & does not correspond " 12003 & "to ancestor discriminant", Actual, Actual_Discr); 12004 Abandon_Instantiation (Actual); 12005 end if; 12006 12007 Next_Discriminant (Actual_Discr); 12008 Next_Discriminant (Ancestor_Discr); 12009 end loop; 12010 12011 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 12012 Error_Msg_NE 12013 ("actual for & must have same number of discriminants", 12014 Actual, Gen_T); 12015 Abandon_Instantiation (Actual); 12016 end if; 12017 12018 -- This case should be caught by the earlier check for 12019 -- constrainedness, but the check here is added for completeness. 12020 12021 elsif Has_Discriminants (Act_T) 12022 and then not Has_Unknown_Discriminants (Act_T) 12023 then 12024 Error_Msg_NE 12025 ("actual for & must not have discriminants", Actual, Gen_T); 12026 Abandon_Instantiation (Actual); 12027 12028 elsif Has_Discriminants (Ancestor) then 12029 Error_Msg_NE 12030 ("actual for & must have known discriminants", Actual, Gen_T); 12031 Abandon_Instantiation (Actual); 12032 end if; 12033 12034 if not Subtypes_Statically_Compatible 12035 (Act_T, Ancestor, Formal_Derived_Matching => True) 12036 then 12037 Error_Msg_N 12038 ("constraint on actual is incompatible with formal", Actual); 12039 Abandon_Instantiation (Actual); 12040 end if; 12041 end if; 12042 12043 -- If the formal and actual types are abstract, check that there 12044 -- are no abstract primitives of the actual type that correspond to 12045 -- nonabstract primitives of the formal type (second sentence of 12046 -- RM95 3.9.3(9)). 12047 12048 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 12049 Check_Abstract_Primitives : declare 12050 Gen_Prims : constant Elist_Id := 12051 Primitive_Operations (A_Gen_T); 12052 Gen_Elmt : Elmt_Id; 12053 Gen_Subp : Entity_Id; 12054 Anc_Subp : Entity_Id; 12055 Anc_Formal : Entity_Id; 12056 Anc_F_Type : Entity_Id; 12057 12058 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 12059 Act_Elmt : Elmt_Id; 12060 Act_Subp : Entity_Id; 12061 Act_Formal : Entity_Id; 12062 Act_F_Type : Entity_Id; 12063 12064 Subprograms_Correspond : Boolean; 12065 12066 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 12067 -- Returns true if T2 is derived directly or indirectly from 12068 -- T1, including derivations from interfaces. T1 and T2 are 12069 -- required to be specific tagged base types. 12070 12071 ------------------------ 12072 -- Is_Tagged_Ancestor -- 12073 ------------------------ 12074 12075 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 12076 is 12077 Intfc_Elmt : Elmt_Id; 12078 12079 begin 12080 -- The predicate is satisfied if the types are the same 12081 12082 if T1 = T2 then 12083 return True; 12084 12085 -- If we've reached the top of the derivation chain then 12086 -- we know that T1 is not an ancestor of T2. 12087 12088 elsif Etype (T2) = T2 then 12089 return False; 12090 12091 -- Proceed to check T2's immediate parent 12092 12093 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 12094 return True; 12095 12096 -- Finally, check to see if T1 is an ancestor of any of T2's 12097 -- progenitors. 12098 12099 else 12100 Intfc_Elmt := First_Elmt (Interfaces (T2)); 12101 while Present (Intfc_Elmt) loop 12102 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 12103 return True; 12104 end if; 12105 12106 Next_Elmt (Intfc_Elmt); 12107 end loop; 12108 end if; 12109 12110 return False; 12111 end Is_Tagged_Ancestor; 12112 12113 -- Start of processing for Check_Abstract_Primitives 12114 12115 begin 12116 -- Loop over all of the formal derived type's primitives 12117 12118 Gen_Elmt := First_Elmt (Gen_Prims); 12119 while Present (Gen_Elmt) loop 12120 Gen_Subp := Node (Gen_Elmt); 12121 12122 -- If the primitive of the formal is not abstract, then 12123 -- determine whether there is a corresponding primitive of 12124 -- the actual type that's abstract. 12125 12126 if not Is_Abstract_Subprogram (Gen_Subp) then 12127 Act_Elmt := First_Elmt (Act_Prims); 12128 while Present (Act_Elmt) loop 12129 Act_Subp := Node (Act_Elmt); 12130 12131 -- If we find an abstract primitive of the actual, 12132 -- then we need to test whether it corresponds to the 12133 -- subprogram from which the generic formal primitive 12134 -- is inherited. 12135 12136 if Is_Abstract_Subprogram (Act_Subp) then 12137 Anc_Subp := Alias (Gen_Subp); 12138 12139 -- Test whether we have a corresponding primitive 12140 -- by comparing names, kinds, formal types, and 12141 -- result types. 12142 12143 if Chars (Anc_Subp) = Chars (Act_Subp) 12144 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 12145 then 12146 Anc_Formal := First_Formal (Anc_Subp); 12147 Act_Formal := First_Formal (Act_Subp); 12148 while Present (Anc_Formal) 12149 and then Present (Act_Formal) 12150 loop 12151 Anc_F_Type := Etype (Anc_Formal); 12152 Act_F_Type := Etype (Act_Formal); 12153 12154 if Ekind (Anc_F_Type) = 12155 E_Anonymous_Access_Type 12156 then 12157 Anc_F_Type := Designated_Type (Anc_F_Type); 12158 12159 if Ekind (Act_F_Type) = 12160 E_Anonymous_Access_Type 12161 then 12162 Act_F_Type := 12163 Designated_Type (Act_F_Type); 12164 else 12165 exit; 12166 end if; 12167 12168 elsif 12169 Ekind (Act_F_Type) = E_Anonymous_Access_Type 12170 then 12171 exit; 12172 end if; 12173 12174 Anc_F_Type := Base_Type (Anc_F_Type); 12175 Act_F_Type := Base_Type (Act_F_Type); 12176 12177 -- If the formal is controlling, then the 12178 -- the type of the actual primitive's formal 12179 -- must be derived directly or indirectly 12180 -- from the type of the ancestor primitive's 12181 -- formal. 12182 12183 if Is_Controlling_Formal (Anc_Formal) then 12184 if not Is_Tagged_Ancestor 12185 (Anc_F_Type, Act_F_Type) 12186 then 12187 exit; 12188 end if; 12189 12190 -- Otherwise the types of the formals must 12191 -- be the same. 12192 12193 elsif Anc_F_Type /= Act_F_Type then 12194 exit; 12195 end if; 12196 12197 Next_Entity (Anc_Formal); 12198 Next_Entity (Act_Formal); 12199 end loop; 12200 12201 -- If we traversed through all of the formals 12202 -- then so far the subprograms correspond, so 12203 -- now check that any result types correspond. 12204 12205 if No (Anc_Formal) and then No (Act_Formal) then 12206 Subprograms_Correspond := True; 12207 12208 if Ekind (Act_Subp) = E_Function then 12209 Anc_F_Type := Etype (Anc_Subp); 12210 Act_F_Type := Etype (Act_Subp); 12211 12212 if Ekind (Anc_F_Type) = 12213 E_Anonymous_Access_Type 12214 then 12215 Anc_F_Type := 12216 Designated_Type (Anc_F_Type); 12217 12218 if Ekind (Act_F_Type) = 12219 E_Anonymous_Access_Type 12220 then 12221 Act_F_Type := 12222 Designated_Type (Act_F_Type); 12223 else 12224 Subprograms_Correspond := False; 12225 end if; 12226 12227 elsif 12228 Ekind (Act_F_Type) 12229 = E_Anonymous_Access_Type 12230 then 12231 Subprograms_Correspond := False; 12232 end if; 12233 12234 Anc_F_Type := Base_Type (Anc_F_Type); 12235 Act_F_Type := Base_Type (Act_F_Type); 12236 12237 -- Now either the result types must be 12238 -- the same or, if the result type is 12239 -- controlling, the result type of the 12240 -- actual primitive must descend from the 12241 -- result type of the ancestor primitive. 12242 12243 if Subprograms_Correspond 12244 and then Anc_F_Type /= Act_F_Type 12245 and then 12246 Has_Controlling_Result (Anc_Subp) 12247 and then not Is_Tagged_Ancestor 12248 (Anc_F_Type, Act_F_Type) 12249 then 12250 Subprograms_Correspond := False; 12251 end if; 12252 end if; 12253 12254 -- Found a matching subprogram belonging to 12255 -- formal ancestor type, so actual subprogram 12256 -- corresponds and this violates 3.9.3(9). 12257 12258 if Subprograms_Correspond then 12259 Error_Msg_NE 12260 ("abstract subprogram & overrides " 12261 & "nonabstract subprogram of ancestor", 12262 Actual, Act_Subp); 12263 end if; 12264 end if; 12265 end if; 12266 end if; 12267 12268 Next_Elmt (Act_Elmt); 12269 end loop; 12270 end if; 12271 12272 Next_Elmt (Gen_Elmt); 12273 end loop; 12274 end Check_Abstract_Primitives; 12275 end if; 12276 12277 -- Verify that limitedness matches. If parent is a limited 12278 -- interface then the generic formal is not unless declared 12279 -- explicitly so. If not declared limited, the actual cannot be 12280 -- limited (see AI05-0087). 12281 12282 -- Even though this AI is a binding interpretation, we enable the 12283 -- check only in Ada 2012 mode, because this improper construct 12284 -- shows up in user code and in existing B-tests. 12285 12286 if Is_Limited_Type (Act_T) 12287 and then not Is_Limited_Type (A_Gen_T) 12288 and then Ada_Version >= Ada_2012 12289 then 12290 if In_Instance then 12291 null; 12292 else 12293 Error_Msg_NE 12294 ("actual for non-limited & cannot be a limited type", 12295 Actual, Gen_T); 12296 Explain_Limited_Type (Act_T, Actual); 12297 Abandon_Instantiation (Actual); 12298 end if; 12299 end if; 12300 end Validate_Derived_Type_Instance; 12301 12302 ---------------------------------------- 12303 -- Validate_Discriminated_Formal_Type -- 12304 ---------------------------------------- 12305 12306 procedure Validate_Discriminated_Formal_Type is 12307 Formal_Discr : Entity_Id; 12308 Actual_Discr : Entity_Id; 12309 Formal_Subt : Entity_Id; 12310 12311 begin 12312 if Has_Discriminants (A_Gen_T) then 12313 if not Has_Discriminants (Act_T) then 12314 Error_Msg_NE 12315 ("actual for & must have discriminants", Actual, Gen_T); 12316 Abandon_Instantiation (Actual); 12317 12318 elsif Is_Constrained (Act_T) then 12319 Error_Msg_NE 12320 ("actual for & must be unconstrained", Actual, Gen_T); 12321 Abandon_Instantiation (Actual); 12322 12323 else 12324 Formal_Discr := First_Discriminant (A_Gen_T); 12325 Actual_Discr := First_Discriminant (Act_T); 12326 while Formal_Discr /= Empty loop 12327 if Actual_Discr = Empty then 12328 Error_Msg_NE 12329 ("discriminants on actual do not match formal", 12330 Actual, Gen_T); 12331 Abandon_Instantiation (Actual); 12332 end if; 12333 12334 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 12335 12336 -- Access discriminants match if designated types do 12337 12338 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 12339 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 12340 E_Anonymous_Access_Type 12341 and then 12342 Get_Instance_Of 12343 (Designated_Type (Base_Type (Formal_Subt))) = 12344 Designated_Type (Base_Type (Etype (Actual_Discr))) 12345 then 12346 null; 12347 12348 elsif Base_Type (Formal_Subt) /= 12349 Base_Type (Etype (Actual_Discr)) 12350 then 12351 Error_Msg_NE 12352 ("types of actual discriminants must match formal", 12353 Actual, Gen_T); 12354 Abandon_Instantiation (Actual); 12355 12356 elsif not Subtypes_Statically_Match 12357 (Formal_Subt, Etype (Actual_Discr)) 12358 and then Ada_Version >= Ada_95 12359 then 12360 Error_Msg_NE 12361 ("subtypes of actual discriminants must match formal", 12362 Actual, Gen_T); 12363 Abandon_Instantiation (Actual); 12364 end if; 12365 12366 Next_Discriminant (Formal_Discr); 12367 Next_Discriminant (Actual_Discr); 12368 end loop; 12369 12370 if Actual_Discr /= Empty then 12371 Error_Msg_NE 12372 ("discriminants on actual do not match formal", 12373 Actual, Gen_T); 12374 Abandon_Instantiation (Actual); 12375 end if; 12376 end if; 12377 end if; 12378 end Validate_Discriminated_Formal_Type; 12379 12380 --------------------------------------- 12381 -- Validate_Incomplete_Type_Instance -- 12382 --------------------------------------- 12383 12384 procedure Validate_Incomplete_Type_Instance is 12385 begin 12386 if not Is_Tagged_Type (Act_T) 12387 and then Is_Tagged_Type (A_Gen_T) 12388 then 12389 Error_Msg_NE 12390 ("actual for & must be a tagged type", Actual, Gen_T); 12391 end if; 12392 12393 Validate_Discriminated_Formal_Type; 12394 end Validate_Incomplete_Type_Instance; 12395 12396 -------------------------------------- 12397 -- Validate_Interface_Type_Instance -- 12398 -------------------------------------- 12399 12400 procedure Validate_Interface_Type_Instance is 12401 begin 12402 if not Is_Interface (Act_T) then 12403 Error_Msg_NE 12404 ("actual for formal interface type must be an interface", 12405 Actual, Gen_T); 12406 12407 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 12408 or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 12409 or else Is_Protected_Interface (A_Gen_T) /= 12410 Is_Protected_Interface (Act_T) 12411 or else Is_Synchronized_Interface (A_Gen_T) /= 12412 Is_Synchronized_Interface (Act_T) 12413 then 12414 Error_Msg_NE 12415 ("actual for interface& does not match (RM 12.5.5(4))", 12416 Actual, Gen_T); 12417 end if; 12418 end Validate_Interface_Type_Instance; 12419 12420 ------------------------------------ 12421 -- Validate_Private_Type_Instance -- 12422 ------------------------------------ 12423 12424 procedure Validate_Private_Type_Instance is 12425 begin 12426 if Is_Limited_Type (Act_T) 12427 and then not Is_Limited_Type (A_Gen_T) 12428 then 12429 if In_Instance then 12430 null; 12431 else 12432 Error_Msg_NE 12433 ("actual for non-limited & cannot be a limited type", Actual, 12434 Gen_T); 12435 Explain_Limited_Type (Act_T, Actual); 12436 Abandon_Instantiation (Actual); 12437 end if; 12438 12439 elsif Known_To_Have_Preelab_Init (A_Gen_T) 12440 and then not Has_Preelaborable_Initialization (Act_T) 12441 then 12442 Error_Msg_NE 12443 ("actual for & must have preelaborable initialization", Actual, 12444 Gen_T); 12445 12446 elsif not Is_Definite_Subtype (Act_T) 12447 and then Is_Definite_Subtype (A_Gen_T) 12448 and then Ada_Version >= Ada_95 12449 then 12450 Error_Msg_NE 12451 ("actual for & must be a definite subtype", Actual, Gen_T); 12452 12453 elsif not Is_Tagged_Type (Act_T) 12454 and then Is_Tagged_Type (A_Gen_T) 12455 then 12456 Error_Msg_NE 12457 ("actual for & must be a tagged type", Actual, Gen_T); 12458 end if; 12459 12460 Validate_Discriminated_Formal_Type; 12461 Ancestor := Gen_T; 12462 end Validate_Private_Type_Instance; 12463 12464 -- Start of processing for Instantiate_Type 12465 12466 begin 12467 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 12468 Error_Msg_N ("duplicate instantiation of generic type", Actual); 12469 return New_List (Error); 12470 12471 elsif not Is_Entity_Name (Actual) 12472 or else not Is_Type (Entity (Actual)) 12473 then 12474 Error_Msg_NE 12475 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 12476 Abandon_Instantiation (Actual); 12477 12478 else 12479 Act_T := Entity (Actual); 12480 12481 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 12482 -- as a generic actual parameter if the corresponding formal type 12483 -- does not have a known_discriminant_part, or is a formal derived 12484 -- type that is an Unchecked_Union type. 12485 12486 if Is_Unchecked_Union (Base_Type (Act_T)) then 12487 if not Has_Discriminants (A_Gen_T) 12488 or else (Is_Derived_Type (A_Gen_T) 12489 and then Is_Unchecked_Union (A_Gen_T)) 12490 then 12491 null; 12492 else 12493 Error_Msg_N ("unchecked union cannot be the actual for a " 12494 & "discriminated formal type", Act_T); 12495 12496 end if; 12497 end if; 12498 12499 -- Deal with fixed/floating restrictions 12500 12501 if Is_Floating_Point_Type (Act_T) then 12502 Check_Restriction (No_Floating_Point, Actual); 12503 elsif Is_Fixed_Point_Type (Act_T) then 12504 Check_Restriction (No_Fixed_Point, Actual); 12505 end if; 12506 12507 -- Deal with error of using incomplete type as generic actual. 12508 -- This includes limited views of a type, even if the non-limited 12509 -- view may be available. 12510 12511 if Ekind (Act_T) = E_Incomplete_Type 12512 or else (Is_Class_Wide_Type (Act_T) 12513 and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 12514 then 12515 -- If the formal is an incomplete type, the actual can be 12516 -- incomplete as well. 12517 12518 if Ekind (A_Gen_T) = E_Incomplete_Type then 12519 null; 12520 12521 elsif Is_Class_Wide_Type (Act_T) 12522 or else No (Full_View (Act_T)) 12523 then 12524 Error_Msg_N ("premature use of incomplete type", Actual); 12525 Abandon_Instantiation (Actual); 12526 else 12527 Act_T := Full_View (Act_T); 12528 Set_Entity (Actual, Act_T); 12529 12530 if Has_Private_Component (Act_T) then 12531 Error_Msg_N 12532 ("premature use of type with private component", Actual); 12533 end if; 12534 end if; 12535 12536 -- Deal with error of premature use of private type as generic actual 12537 12538 elsif Is_Private_Type (Act_T) 12539 and then Is_Private_Type (Base_Type (Act_T)) 12540 and then not Is_Generic_Type (Act_T) 12541 and then not Is_Derived_Type (Act_T) 12542 and then No (Full_View (Root_Type (Act_T))) 12543 then 12544 -- If the formal is an incomplete type, the actual can be 12545 -- private or incomplete as well. 12546 12547 if Ekind (A_Gen_T) = E_Incomplete_Type then 12548 null; 12549 else 12550 Error_Msg_N ("premature use of private type", Actual); 12551 end if; 12552 12553 elsif Has_Private_Component (Act_T) then 12554 Error_Msg_N 12555 ("premature use of type with private component", Actual); 12556 end if; 12557 12558 Set_Instance_Of (A_Gen_T, Act_T); 12559 12560 -- If the type is generic, the class-wide type may also be used 12561 12562 if Is_Tagged_Type (A_Gen_T) 12563 and then Is_Tagged_Type (Act_T) 12564 and then not Is_Class_Wide_Type (A_Gen_T) 12565 then 12566 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 12567 Class_Wide_Type (Act_T)); 12568 end if; 12569 12570 if not Is_Abstract_Type (A_Gen_T) 12571 and then Is_Abstract_Type (Act_T) 12572 then 12573 Error_Msg_N 12574 ("actual of non-abstract formal cannot be abstract", Actual); 12575 end if; 12576 12577 -- A generic scalar type is a first subtype for which we generate 12578 -- an anonymous base type. Indicate that the instance of this base 12579 -- is the base type of the actual. 12580 12581 if Is_Scalar_Type (A_Gen_T) then 12582 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 12583 end if; 12584 end if; 12585 12586 if Error_Posted (Act_T) then 12587 null; 12588 else 12589 case Nkind (Def) is 12590 when N_Formal_Private_Type_Definition => 12591 Validate_Private_Type_Instance; 12592 12593 when N_Formal_Incomplete_Type_Definition => 12594 Validate_Incomplete_Type_Instance; 12595 12596 when N_Formal_Derived_Type_Definition => 12597 Validate_Derived_Type_Instance; 12598 12599 when N_Formal_Discrete_Type_Definition => 12600 if not Is_Discrete_Type (Act_T) then 12601 Error_Msg_NE 12602 ("expect discrete type in instantiation of&", 12603 Actual, Gen_T); 12604 Abandon_Instantiation (Actual); 12605 end if; 12606 12607 Diagnose_Predicated_Actual; 12608 12609 when N_Formal_Signed_Integer_Type_Definition => 12610 if not Is_Signed_Integer_Type (Act_T) then 12611 Error_Msg_NE 12612 ("expect signed integer type in instantiation of&", 12613 Actual, Gen_T); 12614 Abandon_Instantiation (Actual); 12615 end if; 12616 12617 Diagnose_Predicated_Actual; 12618 12619 when N_Formal_Modular_Type_Definition => 12620 if not Is_Modular_Integer_Type (Act_T) then 12621 Error_Msg_NE 12622 ("expect modular type in instantiation of &", 12623 Actual, Gen_T); 12624 Abandon_Instantiation (Actual); 12625 end if; 12626 12627 Diagnose_Predicated_Actual; 12628 12629 when N_Formal_Floating_Point_Definition => 12630 if not Is_Floating_Point_Type (Act_T) then 12631 Error_Msg_NE 12632 ("expect float type in instantiation of &", Actual, Gen_T); 12633 Abandon_Instantiation (Actual); 12634 end if; 12635 12636 when N_Formal_Ordinary_Fixed_Point_Definition => 12637 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 12638 Error_Msg_NE 12639 ("expect ordinary fixed point type in instantiation of &", 12640 Actual, Gen_T); 12641 Abandon_Instantiation (Actual); 12642 end if; 12643 12644 when N_Formal_Decimal_Fixed_Point_Definition => 12645 if not Is_Decimal_Fixed_Point_Type (Act_T) then 12646 Error_Msg_NE 12647 ("expect decimal type in instantiation of &", 12648 Actual, Gen_T); 12649 Abandon_Instantiation (Actual); 12650 end if; 12651 12652 when N_Array_Type_Definition => 12653 Validate_Array_Type_Instance; 12654 12655 when N_Access_To_Object_Definition => 12656 Validate_Access_Type_Instance; 12657 12658 when N_Access_Function_Definition | 12659 N_Access_Procedure_Definition => 12660 Validate_Access_Subprogram_Instance; 12661 12662 when N_Record_Definition => 12663 Validate_Interface_Type_Instance; 12664 12665 when N_Derived_Type_Definition => 12666 Validate_Derived_Interface_Type_Instance; 12667 12668 when others => 12669 raise Program_Error; 12670 12671 end case; 12672 end if; 12673 12674 Subt := New_Copy (Gen_T); 12675 12676 -- Use adjusted sloc of subtype name as the location for other nodes in 12677 -- the subtype declaration. 12678 12679 Loc := Sloc (Subt); 12680 12681 Decl_Node := 12682 Make_Subtype_Declaration (Loc, 12683 Defining_Identifier => Subt, 12684 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); 12685 12686 if Is_Private_Type (Act_T) then 12687 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 12688 12689 elsif Is_Access_Type (Act_T) 12690 and then Is_Private_Type (Designated_Type (Act_T)) 12691 then 12692 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 12693 end if; 12694 12695 -- In Ada 2012 the actual may be a limited view. Indicate that 12696 -- the local subtype must be treated as such. 12697 12698 if From_Limited_With (Act_T) then 12699 Set_Ekind (Subt, E_Incomplete_Subtype); 12700 Set_From_Limited_With (Subt); 12701 end if; 12702 12703 Decl_Nodes := New_List (Decl_Node); 12704 12705 -- Flag actual derived types so their elaboration produces the 12706 -- appropriate renamings for the primitive operations of the ancestor. 12707 -- Flag actual for formal private types as well, to determine whether 12708 -- operations in the private part may override inherited operations. 12709 -- If the formal has an interface list, the ancestor is not the 12710 -- parent, but the analyzed formal that includes the interface 12711 -- operations of all its progenitors. 12712 12713 -- Same treatment for formal private types, so we can check whether the 12714 -- type is tagged limited when validating derivations in the private 12715 -- part. (See AI05-096). 12716 12717 if Nkind (Def) = N_Formal_Derived_Type_Definition then 12718 if Present (Interface_List (Def)) then 12719 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 12720 else 12721 Set_Generic_Parent_Type (Decl_Node, Ancestor); 12722 end if; 12723 12724 elsif Nkind_In (Def, N_Formal_Private_Type_Definition, 12725 N_Formal_Incomplete_Type_Definition) 12726 then 12727 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 12728 end if; 12729 12730 -- If the actual is a synchronized type that implements an interface, 12731 -- the primitive operations are attached to the corresponding record, 12732 -- and we have to treat it as an additional generic actual, so that its 12733 -- primitive operations become visible in the instance. The task or 12734 -- protected type itself does not carry primitive operations. 12735 12736 if Is_Concurrent_Type (Act_T) 12737 and then Is_Tagged_Type (Act_T) 12738 and then Present (Corresponding_Record_Type (Act_T)) 12739 and then Present (Ancestor) 12740 and then Is_Interface (Ancestor) 12741 then 12742 declare 12743 Corr_Rec : constant Entity_Id := 12744 Corresponding_Record_Type (Act_T); 12745 New_Corr : Entity_Id; 12746 Corr_Decl : Node_Id; 12747 12748 begin 12749 New_Corr := Make_Temporary (Loc, 'S'); 12750 Corr_Decl := 12751 Make_Subtype_Declaration (Loc, 12752 Defining_Identifier => New_Corr, 12753 Subtype_Indication => 12754 New_Occurrence_Of (Corr_Rec, Loc)); 12755 Append_To (Decl_Nodes, Corr_Decl); 12756 12757 if Ekind (Act_T) = E_Task_Type then 12758 Set_Ekind (Subt, E_Task_Subtype); 12759 else 12760 Set_Ekind (Subt, E_Protected_Subtype); 12761 end if; 12762 12763 Set_Corresponding_Record_Type (Subt, Corr_Rec); 12764 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 12765 Set_Generic_Parent_Type (Decl_Node, Empty); 12766 end; 12767 end if; 12768 12769 -- For a floating-point type, capture dimension info if any, because 12770 -- the generated subtype declaration does not come from source and 12771 -- will not process dimensions. 12772 12773 if Is_Floating_Point_Type (Act_T) then 12774 Copy_Dimensions (Act_T, Subt); 12775 end if; 12776 12777 return Decl_Nodes; 12778 end Instantiate_Type; 12779 12780 --------------------- 12781 -- Is_In_Main_Unit -- 12782 --------------------- 12783 12784 function Is_In_Main_Unit (N : Node_Id) return Boolean is 12785 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 12786 Current_Unit : Node_Id; 12787 12788 begin 12789 if Unum = Main_Unit then 12790 return True; 12791 12792 -- If the current unit is a subunit then it is either the main unit or 12793 -- is being compiled as part of the main unit. 12794 12795 elsif Nkind (N) = N_Compilation_Unit then 12796 return Nkind (Unit (N)) = N_Subunit; 12797 end if; 12798 12799 Current_Unit := Parent (N); 12800 while Present (Current_Unit) 12801 and then Nkind (Current_Unit) /= N_Compilation_Unit 12802 loop 12803 Current_Unit := Parent (Current_Unit); 12804 end loop; 12805 12806 -- The instantiation node is in the main unit, or else the current node 12807 -- (perhaps as the result of nested instantiations) is in the main unit, 12808 -- or in the declaration of the main unit, which in this last case must 12809 -- be a body. 12810 12811 return Unum = Main_Unit 12812 or else Current_Unit = Cunit (Main_Unit) 12813 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 12814 or else (Present (Library_Unit (Current_Unit)) 12815 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 12816 end Is_In_Main_Unit; 12817 12818 ---------------------------- 12819 -- Load_Parent_Of_Generic -- 12820 ---------------------------- 12821 12822 procedure Load_Parent_Of_Generic 12823 (N : Node_Id; 12824 Spec : Node_Id; 12825 Body_Optional : Boolean := False) 12826 is 12827 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 12828 Saved_Style_Check : constant Boolean := Style_Check; 12829 Saved_Warnings : constant Warning_Record := Save_Warnings; 12830 True_Parent : Node_Id; 12831 Inst_Node : Node_Id; 12832 OK : Boolean; 12833 Previous_Instances : constant Elist_Id := New_Elmt_List; 12834 12835 procedure Collect_Previous_Instances (Decls : List_Id); 12836 -- Collect all instantiations in the given list of declarations, that 12837 -- precede the generic that we need to load. If the bodies of these 12838 -- instantiations are available, we must analyze them, to ensure that 12839 -- the public symbols generated are the same when the unit is compiled 12840 -- to generate code, and when it is compiled in the context of a unit 12841 -- that needs a particular nested instance. This process is applied to 12842 -- both package and subprogram instances. 12843 12844 -------------------------------- 12845 -- Collect_Previous_Instances -- 12846 -------------------------------- 12847 12848 procedure Collect_Previous_Instances (Decls : List_Id) is 12849 Decl : Node_Id; 12850 12851 begin 12852 Decl := First (Decls); 12853 while Present (Decl) loop 12854 if Sloc (Decl) >= Sloc (Inst_Node) then 12855 return; 12856 12857 -- If Decl is an instantiation, then record it as requiring 12858 -- instantiation of the corresponding body, except if it is an 12859 -- abbreviated instantiation generated internally for conformance 12860 -- checking purposes only for the case of a formal package 12861 -- declared without a box (see Instantiate_Formal_Package). Such 12862 -- an instantiation does not generate any code (the actual code 12863 -- comes from actual) and thus does not need to be analyzed here. 12864 -- If the instantiation appears with a generic package body it is 12865 -- not analyzed here either. 12866 12867 elsif Nkind (Decl) = N_Package_Instantiation 12868 and then not Is_Internal (Defining_Entity (Decl)) 12869 then 12870 Append_Elmt (Decl, Previous_Instances); 12871 12872 -- For a subprogram instantiation, omit instantiations intrinsic 12873 -- operations (Unchecked_Conversions, etc.) that have no bodies. 12874 12875 elsif Nkind_In (Decl, N_Function_Instantiation, 12876 N_Procedure_Instantiation) 12877 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 12878 then 12879 Append_Elmt (Decl, Previous_Instances); 12880 12881 elsif Nkind (Decl) = N_Package_Declaration then 12882 Collect_Previous_Instances 12883 (Visible_Declarations (Specification (Decl))); 12884 Collect_Previous_Instances 12885 (Private_Declarations (Specification (Decl))); 12886 12887 -- Previous non-generic bodies may contain instances as well 12888 12889 elsif Nkind (Decl) = N_Package_Body 12890 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 12891 then 12892 Collect_Previous_Instances (Declarations (Decl)); 12893 12894 elsif Nkind (Decl) = N_Subprogram_Body 12895 and then not Acts_As_Spec (Decl) 12896 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 12897 then 12898 Collect_Previous_Instances (Declarations (Decl)); 12899 end if; 12900 12901 Next (Decl); 12902 end loop; 12903 end Collect_Previous_Instances; 12904 12905 -- Start of processing for Load_Parent_Of_Generic 12906 12907 begin 12908 if not In_Same_Source_Unit (N, Spec) 12909 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 12910 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 12911 and then not Is_In_Main_Unit (Spec)) 12912 then 12913 -- Find body of parent of spec, and analyze it. A special case arises 12914 -- when the parent is an instantiation, that is to say when we are 12915 -- currently instantiating a nested generic. In that case, there is 12916 -- no separate file for the body of the enclosing instance. Instead, 12917 -- the enclosing body must be instantiated as if it were a pending 12918 -- instantiation, in order to produce the body for the nested generic 12919 -- we require now. Note that in that case the generic may be defined 12920 -- in a package body, the instance defined in the same package body, 12921 -- and the original enclosing body may not be in the main unit. 12922 12923 Inst_Node := Empty; 12924 12925 True_Parent := Parent (Spec); 12926 while Present (True_Parent) 12927 and then Nkind (True_Parent) /= N_Compilation_Unit 12928 loop 12929 if Nkind (True_Parent) = N_Package_Declaration 12930 and then 12931 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 12932 then 12933 -- Parent is a compilation unit that is an instantiation. 12934 -- Instantiation node has been replaced with package decl. 12935 12936 Inst_Node := Original_Node (True_Parent); 12937 exit; 12938 12939 elsif Nkind (True_Parent) = N_Package_Declaration 12940 and then Present (Generic_Parent (Specification (True_Parent))) 12941 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 12942 then 12943 -- Parent is an instantiation within another specification. 12944 -- Declaration for instance has been inserted before original 12945 -- instantiation node. A direct link would be preferable? 12946 12947 Inst_Node := Next (True_Parent); 12948 while Present (Inst_Node) 12949 and then Nkind (Inst_Node) /= N_Package_Instantiation 12950 loop 12951 Next (Inst_Node); 12952 end loop; 12953 12954 -- If the instance appears within a generic, and the generic 12955 -- unit is defined within a formal package of the enclosing 12956 -- generic, there is no generic body available, and none 12957 -- needed. A more precise test should be used ??? 12958 12959 if No (Inst_Node) then 12960 return; 12961 end if; 12962 12963 exit; 12964 12965 else 12966 True_Parent := Parent (True_Parent); 12967 end if; 12968 end loop; 12969 12970 -- Case where we are currently instantiating a nested generic 12971 12972 if Present (Inst_Node) then 12973 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 12974 12975 -- Instantiation node and declaration of instantiated package 12976 -- were exchanged when only the declaration was needed. 12977 -- Restore instantiation node before proceeding with body. 12978 12979 Set_Unit (Parent (True_Parent), Inst_Node); 12980 end if; 12981 12982 -- Now complete instantiation of enclosing body, if it appears in 12983 -- some other unit. If it appears in the current unit, the body 12984 -- will have been instantiated already. 12985 12986 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 12987 12988 -- We need to determine the expander mode to instantiate the 12989 -- enclosing body. Because the generic body we need may use 12990 -- global entities declared in the enclosing package (including 12991 -- aggregates) it is in general necessary to compile this body 12992 -- with expansion enabled, except if we are within a generic 12993 -- package, in which case the usual generic rule applies. 12994 12995 declare 12996 Exp_Status : Boolean := True; 12997 Scop : Entity_Id; 12998 12999 begin 13000 -- Loop through scopes looking for generic package 13001 13002 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 13003 while Present (Scop) 13004 and then Scop /= Standard_Standard 13005 loop 13006 if Ekind (Scop) = E_Generic_Package then 13007 Exp_Status := False; 13008 exit; 13009 end if; 13010 13011 Scop := Scope (Scop); 13012 end loop; 13013 13014 -- Collect previous instantiations in the unit that contains 13015 -- the desired generic. 13016 13017 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13018 and then not Body_Optional 13019 then 13020 declare 13021 Decl : Elmt_Id; 13022 Info : Pending_Body_Info; 13023 Par : Node_Id; 13024 13025 begin 13026 Par := Parent (Inst_Node); 13027 while Present (Par) loop 13028 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 13029 Par := Parent (Par); 13030 end loop; 13031 13032 pragma Assert (Present (Par)); 13033 13034 if Nkind (Par) = N_Package_Body then 13035 Collect_Previous_Instances (Declarations (Par)); 13036 13037 elsif Nkind (Par) = N_Package_Declaration then 13038 Collect_Previous_Instances 13039 (Visible_Declarations (Specification (Par))); 13040 Collect_Previous_Instances 13041 (Private_Declarations (Specification (Par))); 13042 13043 else 13044 -- Enclosing unit is a subprogram body. In this 13045 -- case all instance bodies are processed in order 13046 -- and there is no need to collect them separately. 13047 13048 null; 13049 end if; 13050 13051 Decl := First_Elmt (Previous_Instances); 13052 while Present (Decl) loop 13053 Info := 13054 (Inst_Node => Node (Decl), 13055 Act_Decl => 13056 Instance_Spec (Node (Decl)), 13057 Expander_Status => Exp_Status, 13058 Current_Sem_Unit => 13059 Get_Code_Unit (Sloc (Node (Decl))), 13060 Scope_Suppress => Scope_Suppress, 13061 Local_Suppress_Stack_Top => 13062 Local_Suppress_Stack_Top, 13063 Version => Ada_Version, 13064 Version_Pragma => Ada_Version_Pragma, 13065 Warnings => Save_Warnings, 13066 SPARK_Mode => SPARK_Mode, 13067 SPARK_Mode_Pragma => SPARK_Mode_Pragma); 13068 13069 -- Package instance 13070 13071 if 13072 Nkind (Node (Decl)) = N_Package_Instantiation 13073 then 13074 Instantiate_Package_Body 13075 (Info, Body_Optional => True); 13076 13077 -- Subprogram instance 13078 13079 else 13080 -- The instance_spec is in the wrapper package, 13081 -- usually followed by its local renaming 13082 -- declaration. See Build_Subprogram_Renaming 13083 -- for details. 13084 13085 declare 13086 Decl : Node_Id := 13087 (Last (Visible_Declarations 13088 (Specification (Info.Act_Decl)))); 13089 begin 13090 if Nkind (Decl) = 13091 N_Subprogram_Renaming_Declaration 13092 then 13093 Decl := Prev (Decl); 13094 end if; 13095 13096 Info.Act_Decl := Decl; 13097 end; 13098 13099 Instantiate_Subprogram_Body 13100 (Info, Body_Optional => True); 13101 end if; 13102 13103 Next_Elmt (Decl); 13104 end loop; 13105 end; 13106 end if; 13107 13108 Instantiate_Package_Body 13109 (Body_Info => 13110 ((Inst_Node => Inst_Node, 13111 Act_Decl => True_Parent, 13112 Expander_Status => Exp_Status, 13113 Current_Sem_Unit => Get_Code_Unit 13114 (Sloc (Inst_Node)), 13115 Scope_Suppress => Scope_Suppress, 13116 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 13117 Version => Ada_Version, 13118 Version_Pragma => Ada_Version_Pragma, 13119 Warnings => Save_Warnings, 13120 SPARK_Mode => SPARK_Mode, 13121 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 13122 Body_Optional => Body_Optional); 13123 end; 13124 end if; 13125 13126 -- Case where we are not instantiating a nested generic 13127 13128 else 13129 Opt.Style_Check := False; 13130 Expander_Mode_Save_And_Set (True); 13131 Load_Needed_Body (Comp_Unit, OK); 13132 Opt.Style_Check := Saved_Style_Check; 13133 Restore_Warnings (Saved_Warnings); 13134 Expander_Mode_Restore; 13135 13136 if not OK 13137 and then Unit_Requires_Body (Defining_Entity (Spec)) 13138 and then not Body_Optional 13139 then 13140 declare 13141 Bname : constant Unit_Name_Type := 13142 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 13143 13144 begin 13145 -- In CodePeer mode, the missing body may make the analysis 13146 -- incomplete, but we do not treat it as fatal. 13147 13148 if CodePeer_Mode then 13149 return; 13150 13151 else 13152 Error_Msg_Unit_1 := Bname; 13153 Error_Msg_N ("this instantiation requires$!", N); 13154 Error_Msg_File_1 := 13155 Get_File_Name (Bname, Subunit => False); 13156 Error_Msg_N ("\but file{ was not found!", N); 13157 raise Unrecoverable_Error; 13158 end if; 13159 end; 13160 end if; 13161 end if; 13162 end if; 13163 13164 -- If loading parent of the generic caused an instantiation circularity, 13165 -- we abandon compilation at this point, because otherwise in some cases 13166 -- we get into trouble with infinite recursions after this point. 13167 13168 if Circularity_Detected then 13169 raise Unrecoverable_Error; 13170 end if; 13171 end Load_Parent_Of_Generic; 13172 13173 --------------------------------- 13174 -- Map_Formal_Package_Entities -- 13175 --------------------------------- 13176 13177 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 13178 E1 : Entity_Id; 13179 E2 : Entity_Id; 13180 13181 begin 13182 Set_Instance_Of (Form, Act); 13183 13184 -- Traverse formal and actual package to map the corresponding entities. 13185 -- We skip over internal entities that may be generated during semantic 13186 -- analysis, and find the matching entities by name, given that they 13187 -- must appear in the same order. 13188 13189 E1 := First_Entity (Form); 13190 E2 := First_Entity (Act); 13191 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 13192 -- Could this test be a single condition??? Seems like it could, and 13193 -- isn't FPE (Form) a constant anyway??? 13194 13195 if not Is_Internal (E1) 13196 and then Present (Parent (E1)) 13197 and then not Is_Class_Wide_Type (E1) 13198 and then not Is_Internal_Name (Chars (E1)) 13199 then 13200 while Present (E2) and then Chars (E2) /= Chars (E1) loop 13201 Next_Entity (E2); 13202 end loop; 13203 13204 if No (E2) then 13205 exit; 13206 else 13207 Set_Instance_Of (E1, E2); 13208 13209 if Is_Type (E1) and then Is_Tagged_Type (E2) then 13210 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 13211 end if; 13212 13213 if Is_Constrained (E1) then 13214 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 13215 end if; 13216 13217 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 13218 Map_Formal_Package_Entities (E1, E2); 13219 end if; 13220 end if; 13221 end if; 13222 13223 Next_Entity (E1); 13224 end loop; 13225 end Map_Formal_Package_Entities; 13226 13227 ----------------------- 13228 -- Move_Freeze_Nodes -- 13229 ----------------------- 13230 13231 procedure Move_Freeze_Nodes 13232 (Out_Of : Entity_Id; 13233 After : Node_Id; 13234 L : List_Id) 13235 is 13236 Decl : Node_Id; 13237 Next_Decl : Node_Id; 13238 Next_Node : Node_Id := After; 13239 Spec : Node_Id; 13240 13241 function Is_Outer_Type (T : Entity_Id) return Boolean; 13242 -- Check whether entity is declared in a scope external to that of the 13243 -- generic unit. 13244 13245 ------------------- 13246 -- Is_Outer_Type -- 13247 ------------------- 13248 13249 function Is_Outer_Type (T : Entity_Id) return Boolean is 13250 Scop : Entity_Id := Scope (T); 13251 13252 begin 13253 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 13254 return True; 13255 13256 else 13257 while Scop /= Standard_Standard loop 13258 if Scop = Out_Of then 13259 return False; 13260 else 13261 Scop := Scope (Scop); 13262 end if; 13263 end loop; 13264 13265 return True; 13266 end if; 13267 end Is_Outer_Type; 13268 13269 -- Start of processing for Move_Freeze_Nodes 13270 13271 begin 13272 if No (L) then 13273 return; 13274 end if; 13275 13276 -- First remove the freeze nodes that may appear before all other 13277 -- declarations. 13278 13279 Decl := First (L); 13280 while Present (Decl) 13281 and then Nkind (Decl) = N_Freeze_Entity 13282 and then Is_Outer_Type (Entity (Decl)) 13283 loop 13284 Decl := Remove_Head (L); 13285 Insert_After (Next_Node, Decl); 13286 Set_Analyzed (Decl, False); 13287 Next_Node := Decl; 13288 Decl := First (L); 13289 end loop; 13290 13291 -- Next scan the list of declarations and remove each freeze node that 13292 -- appears ahead of the current node. 13293 13294 while Present (Decl) loop 13295 while Present (Next (Decl)) 13296 and then Nkind (Next (Decl)) = N_Freeze_Entity 13297 and then Is_Outer_Type (Entity (Next (Decl))) 13298 loop 13299 Next_Decl := Remove_Next (Decl); 13300 Insert_After (Next_Node, Next_Decl); 13301 Set_Analyzed (Next_Decl, False); 13302 Next_Node := Next_Decl; 13303 end loop; 13304 13305 -- If the declaration is a nested package or concurrent type, then 13306 -- recurse. Nested generic packages will have been processed from the 13307 -- inside out. 13308 13309 case Nkind (Decl) is 13310 when N_Package_Declaration => 13311 Spec := Specification (Decl); 13312 13313 when N_Task_Type_Declaration => 13314 Spec := Task_Definition (Decl); 13315 13316 when N_Protected_Type_Declaration => 13317 Spec := Protected_Definition (Decl); 13318 13319 when others => 13320 Spec := Empty; 13321 end case; 13322 13323 if Present (Spec) then 13324 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 13325 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 13326 end if; 13327 13328 Next (Decl); 13329 end loop; 13330 end Move_Freeze_Nodes; 13331 13332 ---------------- 13333 -- Next_Assoc -- 13334 ---------------- 13335 13336 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 13337 begin 13338 return Generic_Renamings.Table (E).Next_In_HTable; 13339 end Next_Assoc; 13340 13341 ------------------------ 13342 -- Preanalyze_Actuals -- 13343 ------------------------ 13344 13345 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is 13346 Assoc : Node_Id; 13347 Act : Node_Id; 13348 Errs : constant Int := Serious_Errors_Detected; 13349 13350 Cur : Entity_Id := Empty; 13351 -- Current homograph of the instance name 13352 13353 Vis : Boolean; 13354 -- Saved visibility status of the current homograph 13355 13356 begin 13357 Assoc := First (Generic_Associations (N)); 13358 13359 -- If the instance is a child unit, its name may hide an outer homonym, 13360 -- so make it invisible to perform name resolution on the actuals. 13361 13362 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 13363 and then Present 13364 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 13365 then 13366 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 13367 13368 if Is_Compilation_Unit (Cur) then 13369 Vis := Is_Immediately_Visible (Cur); 13370 Set_Is_Immediately_Visible (Cur, False); 13371 else 13372 Cur := Empty; 13373 end if; 13374 end if; 13375 13376 while Present (Assoc) loop 13377 if Nkind (Assoc) /= N_Others_Choice then 13378 Act := Explicit_Generic_Actual_Parameter (Assoc); 13379 13380 -- Within a nested instantiation, a defaulted actual is an empty 13381 -- association, so nothing to analyze. If the subprogram actual 13382 -- is an attribute, analyze prefix only, because actual is not a 13383 -- complete attribute reference. 13384 13385 -- If actual is an allocator, analyze expression only. The full 13386 -- analysis can generate code, and if instance is a compilation 13387 -- unit we have to wait until the package instance is installed 13388 -- to have a proper place to insert this code. 13389 13390 -- String literals may be operators, but at this point we do not 13391 -- know whether the actual is a formal subprogram or a string. 13392 13393 if No (Act) then 13394 null; 13395 13396 elsif Nkind (Act) = N_Attribute_Reference then 13397 Analyze (Prefix (Act)); 13398 13399 elsif Nkind (Act) = N_Explicit_Dereference then 13400 Analyze (Prefix (Act)); 13401 13402 elsif Nkind (Act) = N_Allocator then 13403 declare 13404 Expr : constant Node_Id := Expression (Act); 13405 13406 begin 13407 if Nkind (Expr) = N_Subtype_Indication then 13408 Analyze (Subtype_Mark (Expr)); 13409 13410 -- Analyze separately each discriminant constraint, when 13411 -- given with a named association. 13412 13413 declare 13414 Constr : Node_Id; 13415 13416 begin 13417 Constr := First (Constraints (Constraint (Expr))); 13418 while Present (Constr) loop 13419 if Nkind (Constr) = N_Discriminant_Association then 13420 Analyze (Expression (Constr)); 13421 else 13422 Analyze (Constr); 13423 end if; 13424 13425 Next (Constr); 13426 end loop; 13427 end; 13428 13429 else 13430 Analyze (Expr); 13431 end if; 13432 end; 13433 13434 elsif Nkind (Act) /= N_Operator_Symbol then 13435 Analyze (Act); 13436 13437 -- Within a package instance, mark actuals that are limited 13438 -- views, so their use can be moved to the body of the 13439 -- enclosing unit. 13440 13441 if Is_Entity_Name (Act) 13442 and then Is_Type (Entity (Act)) 13443 and then From_Limited_With (Entity (Act)) 13444 and then Present (Inst) 13445 then 13446 Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); 13447 end if; 13448 end if; 13449 13450 if Errs /= Serious_Errors_Detected then 13451 13452 -- Do a minimal analysis of the generic, to prevent spurious 13453 -- warnings complaining about the generic being unreferenced, 13454 -- before abandoning the instantiation. 13455 13456 Analyze (Name (N)); 13457 13458 if Is_Entity_Name (Name (N)) 13459 and then Etype (Name (N)) /= Any_Type 13460 then 13461 Generate_Reference (Entity (Name (N)), Name (N)); 13462 Set_Is_Instantiated (Entity (Name (N))); 13463 end if; 13464 13465 if Present (Cur) then 13466 13467 -- For the case of a child instance hiding an outer homonym, 13468 -- provide additional warning which might explain the error. 13469 13470 Set_Is_Immediately_Visible (Cur, Vis); 13471 Error_Msg_NE 13472 ("& hides outer unit with the same name??", 13473 N, Defining_Unit_Name (N)); 13474 end if; 13475 13476 Abandon_Instantiation (Act); 13477 end if; 13478 end if; 13479 13480 Next (Assoc); 13481 end loop; 13482 13483 if Present (Cur) then 13484 Set_Is_Immediately_Visible (Cur, Vis); 13485 end if; 13486 end Preanalyze_Actuals; 13487 13488 ------------------- 13489 -- Remove_Parent -- 13490 ------------------- 13491 13492 procedure Remove_Parent (In_Body : Boolean := False) is 13493 S : Entity_Id := Current_Scope; 13494 -- S is the scope containing the instantiation just completed. The scope 13495 -- stack contains the parent instances of the instantiation, followed by 13496 -- the original S. 13497 13498 Cur_P : Entity_Id; 13499 E : Entity_Id; 13500 P : Entity_Id; 13501 Hidden : Elmt_Id; 13502 13503 begin 13504 -- After child instantiation is complete, remove from scope stack the 13505 -- extra copy of the current scope, and then remove parent instances. 13506 13507 if not In_Body then 13508 Pop_Scope; 13509 13510 while Current_Scope /= S loop 13511 P := Current_Scope; 13512 End_Package_Scope (Current_Scope); 13513 13514 if In_Open_Scopes (P) then 13515 E := First_Entity (P); 13516 while Present (E) loop 13517 Set_Is_Immediately_Visible (E, True); 13518 Next_Entity (E); 13519 end loop; 13520 13521 -- If instantiation is declared in a block, it is the enclosing 13522 -- scope that might be a parent instance. Note that only one 13523 -- block can be involved, because the parent instances have 13524 -- been installed within it. 13525 13526 if Ekind (P) = E_Block then 13527 Cur_P := Scope (P); 13528 else 13529 Cur_P := P; 13530 end if; 13531 13532 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 13533 -- We are within an instance of some sibling. Retain 13534 -- visibility of parent, for proper subsequent cleanup, and 13535 -- reinstall private declarations as well. 13536 13537 Set_In_Private_Part (P); 13538 Install_Private_Declarations (P); 13539 end if; 13540 13541 -- If the ultimate parent is a top-level unit recorded in 13542 -- Instance_Parent_Unit, then reset its visibility to what it was 13543 -- before instantiation. (It's not clear what the purpose is of 13544 -- testing whether Scope (P) is In_Open_Scopes, but that test was 13545 -- present before the ultimate parent test was added.???) 13546 13547 elsif not In_Open_Scopes (Scope (P)) 13548 or else (P = Instance_Parent_Unit 13549 and then not Parent_Unit_Visible) 13550 then 13551 Set_Is_Immediately_Visible (P, False); 13552 13553 -- If the current scope is itself an instantiation of a generic 13554 -- nested within P, and we are in the private part of body of this 13555 -- instantiation, restore the full views of P, that were removed 13556 -- in End_Package_Scope above. This obscure case can occur when a 13557 -- subunit of a generic contains an instance of a child unit of 13558 -- its generic parent unit. 13559 13560 elsif S = Current_Scope and then Is_Generic_Instance (S) then 13561 declare 13562 Par : constant Entity_Id := 13563 Generic_Parent (Package_Specification (S)); 13564 begin 13565 if Present (Par) 13566 and then P = Scope (Par) 13567 and then (In_Package_Body (S) or else In_Private_Part (S)) 13568 then 13569 Set_In_Private_Part (P); 13570 Install_Private_Declarations (P); 13571 end if; 13572 end; 13573 end if; 13574 end loop; 13575 13576 -- Reset visibility of entities in the enclosing scope 13577 13578 Set_Is_Hidden_Open_Scope (Current_Scope, False); 13579 13580 Hidden := First_Elmt (Hidden_Entities); 13581 while Present (Hidden) loop 13582 Set_Is_Immediately_Visible (Node (Hidden), True); 13583 Next_Elmt (Hidden); 13584 end loop; 13585 13586 else 13587 -- Each body is analyzed separately, and there is no context that 13588 -- needs preserving from one body instance to the next, so remove all 13589 -- parent scopes that have been installed. 13590 13591 while Present (S) loop 13592 End_Package_Scope (S); 13593 Set_Is_Immediately_Visible (S, False); 13594 S := Current_Scope; 13595 exit when S = Standard_Standard; 13596 end loop; 13597 end if; 13598 end Remove_Parent; 13599 13600 ----------------- 13601 -- Restore_Env -- 13602 ----------------- 13603 13604 procedure Restore_Env is 13605 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 13606 13607 begin 13608 if No (Current_Instantiated_Parent.Act_Id) then 13609 -- Restore environment after subprogram inlining 13610 13611 Restore_Private_Views (Empty); 13612 end if; 13613 13614 Current_Instantiated_Parent := Saved.Instantiated_Parent; 13615 Exchanged_Views := Saved.Exchanged_Views; 13616 Hidden_Entities := Saved.Hidden_Entities; 13617 Current_Sem_Unit := Saved.Current_Sem_Unit; 13618 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 13619 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 13620 13621 Restore_Opt_Config_Switches (Saved.Switches); 13622 13623 Instance_Envs.Decrement_Last; 13624 end Restore_Env; 13625 13626 --------------------------- 13627 -- Restore_Private_Views -- 13628 --------------------------- 13629 13630 procedure Restore_Private_Views 13631 (Pack_Id : Entity_Id; 13632 Is_Package : Boolean := True) 13633 is 13634 M : Elmt_Id; 13635 E : Entity_Id; 13636 Typ : Entity_Id; 13637 Dep_Elmt : Elmt_Id; 13638 Dep_Typ : Node_Id; 13639 13640 procedure Restore_Nested_Formal (Formal : Entity_Id); 13641 -- Hide the generic formals of formal packages declared with box which 13642 -- were reachable in the current instantiation. 13643 13644 --------------------------- 13645 -- Restore_Nested_Formal -- 13646 --------------------------- 13647 13648 procedure Restore_Nested_Formal (Formal : Entity_Id) is 13649 Ent : Entity_Id; 13650 13651 begin 13652 if Present (Renamed_Object (Formal)) 13653 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 13654 then 13655 return; 13656 13657 elsif Present (Associated_Formal_Package (Formal)) then 13658 Ent := First_Entity (Formal); 13659 while Present (Ent) loop 13660 exit when Ekind (Ent) = E_Package 13661 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 13662 13663 Set_Is_Hidden (Ent); 13664 Set_Is_Potentially_Use_Visible (Ent, False); 13665 13666 -- If package, then recurse 13667 13668 if Ekind (Ent) = E_Package then 13669 Restore_Nested_Formal (Ent); 13670 end if; 13671 13672 Next_Entity (Ent); 13673 end loop; 13674 end if; 13675 end Restore_Nested_Formal; 13676 13677 -- Start of processing for Restore_Private_Views 13678 13679 begin 13680 M := First_Elmt (Exchanged_Views); 13681 while Present (M) loop 13682 Typ := Node (M); 13683 13684 -- Subtypes of types whose views have been exchanged, and that are 13685 -- defined within the instance, were not on the Private_Dependents 13686 -- list on entry to the instance, so they have to be exchanged 13687 -- explicitly now, in order to remain consistent with the view of the 13688 -- parent type. 13689 13690 if Ekind_In (Typ, E_Private_Type, 13691 E_Limited_Private_Type, 13692 E_Record_Type_With_Private) 13693 then 13694 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 13695 while Present (Dep_Elmt) loop 13696 Dep_Typ := Node (Dep_Elmt); 13697 13698 if Scope (Dep_Typ) = Pack_Id 13699 and then Present (Full_View (Dep_Typ)) 13700 then 13701 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 13702 Exchange_Declarations (Dep_Typ); 13703 end if; 13704 13705 Next_Elmt (Dep_Elmt); 13706 end loop; 13707 end if; 13708 13709 Exchange_Declarations (Node (M)); 13710 Next_Elmt (M); 13711 end loop; 13712 13713 if No (Pack_Id) then 13714 return; 13715 end if; 13716 13717 -- Make the generic formal parameters private, and make the formal types 13718 -- into subtypes of the actuals again. 13719 13720 E := First_Entity (Pack_Id); 13721 while Present (E) loop 13722 Set_Is_Hidden (E, True); 13723 13724 if Is_Type (E) 13725 and then Nkind (Parent (E)) = N_Subtype_Declaration 13726 then 13727 -- If the actual for E is itself a generic actual type from 13728 -- an enclosing instance, E is still a generic actual type 13729 -- outside of the current instance. This matter when resolving 13730 -- an overloaded call that may be ambiguous in the enclosing 13731 -- instance, when two of its actuals coincide. 13732 13733 if Is_Entity_Name (Subtype_Indication (Parent (E))) 13734 and then Is_Generic_Actual_Type 13735 (Entity (Subtype_Indication (Parent (E)))) 13736 then 13737 null; 13738 else 13739 Set_Is_Generic_Actual_Type (E, False); 13740 end if; 13741 13742 -- An unusual case of aliasing: the actual may also be directly 13743 -- visible in the generic, and be private there, while it is fully 13744 -- visible in the context of the instance. The internal subtype 13745 -- is private in the instance but has full visibility like its 13746 -- parent in the enclosing scope. This enforces the invariant that 13747 -- the privacy status of all private dependents of a type coincide 13748 -- with that of the parent type. This can only happen when a 13749 -- generic child unit is instantiated within a sibling. 13750 13751 if Is_Private_Type (E) 13752 and then not Is_Private_Type (Etype (E)) 13753 then 13754 Exchange_Declarations (E); 13755 end if; 13756 13757 elsif Ekind (E) = E_Package then 13758 13759 -- The end of the renaming list is the renaming of the generic 13760 -- package itself. If the instance is a subprogram, all entities 13761 -- in the corresponding package are renamings. If this entity is 13762 -- a formal package, make its own formals private as well. The 13763 -- actual in this case is itself the renaming of an instantiation. 13764 -- If the entity is not a package renaming, it is the entity 13765 -- created to validate formal package actuals: ignore it. 13766 13767 -- If the actual is itself a formal package for the enclosing 13768 -- generic, or the actual for such a formal package, it remains 13769 -- visible on exit from the instance, and therefore nothing needs 13770 -- to be done either, except to keep it accessible. 13771 13772 if Is_Package and then Renamed_Object (E) = Pack_Id then 13773 exit; 13774 13775 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 13776 null; 13777 13778 elsif 13779 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 13780 then 13781 Set_Is_Hidden (E, False); 13782 13783 else 13784 declare 13785 Act_P : constant Entity_Id := Renamed_Object (E); 13786 Id : Entity_Id; 13787 13788 begin 13789 Id := First_Entity (Act_P); 13790 while Present (Id) 13791 and then Id /= First_Private_Entity (Act_P) 13792 loop 13793 exit when Ekind (Id) = E_Package 13794 and then Renamed_Object (Id) = Act_P; 13795 13796 Set_Is_Hidden (Id, True); 13797 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 13798 13799 if Ekind (Id) = E_Package then 13800 Restore_Nested_Formal (Id); 13801 end if; 13802 13803 Next_Entity (Id); 13804 end loop; 13805 end; 13806 end if; 13807 end if; 13808 13809 Next_Entity (E); 13810 end loop; 13811 end Restore_Private_Views; 13812 13813 -------------- 13814 -- Save_Env -- 13815 -------------- 13816 13817 procedure Save_Env 13818 (Gen_Unit : Entity_Id; 13819 Act_Unit : Entity_Id) 13820 is 13821 begin 13822 Init_Env; 13823 Set_Instance_Env (Gen_Unit, Act_Unit); 13824 end Save_Env; 13825 13826 ---------------------------- 13827 -- Save_Global_References -- 13828 ---------------------------- 13829 13830 procedure Save_Global_References (Templ : Node_Id) is 13831 13832 -- ??? it is horrible to use global variables in highly recursive code 13833 13834 E : Entity_Id; 13835 -- The entity of the current associated node 13836 13837 Gen_Scope : Entity_Id; 13838 -- The scope of the generic for which references are being saved 13839 13840 N2 : Node_Id; 13841 -- The current associated node 13842 13843 function Is_Global (E : Entity_Id) return Boolean; 13844 -- Check whether entity is defined outside of generic unit. Examine the 13845 -- scope of an entity, and the scope of the scope, etc, until we find 13846 -- either Standard, in which case the entity is global, or the generic 13847 -- unit itself, which indicates that the entity is local. If the entity 13848 -- is the generic unit itself, as in the case of a recursive call, or 13849 -- the enclosing generic unit, if different from the current scope, then 13850 -- it is local as well, because it will be replaced at the point of 13851 -- instantiation. On the other hand, if it is a reference to a child 13852 -- unit of a common ancestor, which appears in an instantiation, it is 13853 -- global because it is used to denote a specific compilation unit at 13854 -- the time the instantiations will be analyzed. 13855 13856 procedure Reset_Entity (N : Node_Id); 13857 -- Save semantic information on global entity so that it is not resolved 13858 -- again at instantiation time. 13859 13860 procedure Save_Entity_Descendants (N : Node_Id); 13861 -- Apply Save_Global_References to the two syntactic descendants of 13862 -- non-terminal nodes that carry an Associated_Node and are processed 13863 -- through Reset_Entity. Once the global entity (if any) has been 13864 -- captured together with its type, only two syntactic descendants need 13865 -- to be traversed to complete the processing of the tree rooted at N. 13866 -- This applies to Selected_Components, Expanded_Names, and to Operator 13867 -- nodes. N can also be a character literal, identifier, or operator 13868 -- symbol node, but the call has no effect in these cases. 13869 13870 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id); 13871 -- Default actuals in nested instances must be handled specially 13872 -- because there is no link to them from the original tree. When an 13873 -- actual subprogram is given by a default, we add an explicit generic 13874 -- association for it in the instantiation node. When we save the 13875 -- global references on the name of the instance, we recover the list 13876 -- of generic associations, and add an explicit one to the original 13877 -- generic tree, through which a global actual can be preserved. 13878 -- Similarly, if a child unit is instantiated within a sibling, in the 13879 -- context of the parent, we must preserve the identifier of the parent 13880 -- so that it can be properly resolved in a subsequent instantiation. 13881 13882 procedure Save_Global_Descendant (D : Union_Id); 13883 -- Apply Save_References recursively to the descendents of node D 13884 13885 procedure Save_References (N : Node_Id); 13886 -- This is the recursive procedure that does the work, once the 13887 -- enclosing generic scope has been established. 13888 13889 --------------- 13890 -- Is_Global -- 13891 --------------- 13892 13893 function Is_Global (E : Entity_Id) return Boolean is 13894 Se : Entity_Id; 13895 13896 function Is_Instance_Node (Decl : Node_Id) return Boolean; 13897 -- Determine whether the parent node of a reference to a child unit 13898 -- denotes an instantiation or a formal package, in which case the 13899 -- reference to the child unit is global, even if it appears within 13900 -- the current scope (e.g. when the instance appears within the body 13901 -- of an ancestor). 13902 13903 ---------------------- 13904 -- Is_Instance_Node -- 13905 ---------------------- 13906 13907 function Is_Instance_Node (Decl : Node_Id) return Boolean is 13908 begin 13909 return Nkind (Decl) in N_Generic_Instantiation 13910 or else 13911 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 13912 end Is_Instance_Node; 13913 13914 -- Start of processing for Is_Global 13915 13916 begin 13917 if E = Gen_Scope then 13918 return False; 13919 13920 elsif E = Standard_Standard then 13921 return True; 13922 13923 elsif Is_Child_Unit (E) 13924 and then (Is_Instance_Node (Parent (N2)) 13925 or else (Nkind (Parent (N2)) = N_Expanded_Name 13926 and then N2 = Selector_Name (Parent (N2)) 13927 and then 13928 Is_Instance_Node (Parent (Parent (N2))))) 13929 then 13930 return True; 13931 13932 else 13933 Se := Scope (E); 13934 while Se /= Gen_Scope loop 13935 if Se = Standard_Standard then 13936 return True; 13937 else 13938 Se := Scope (Se); 13939 end if; 13940 end loop; 13941 13942 return False; 13943 end if; 13944 end Is_Global; 13945 13946 ------------------ 13947 -- Reset_Entity -- 13948 ------------------ 13949 13950 procedure Reset_Entity (N : Node_Id) is 13951 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 13952 -- If the type of N2 is global to the generic unit, save the type in 13953 -- the generic node. Just as we perform name capture for explicit 13954 -- references within the generic, we must capture the global types 13955 -- of local entities because they may participate in resolution in 13956 -- the instance. 13957 13958 function Top_Ancestor (E : Entity_Id) return Entity_Id; 13959 -- Find the ultimate ancestor of the current unit. If it is not a 13960 -- generic unit, then the name of the current unit in the prefix of 13961 -- an expanded name must be replaced with its generic homonym to 13962 -- ensure that it will be properly resolved in an instance. 13963 13964 --------------------- 13965 -- Set_Global_Type -- 13966 --------------------- 13967 13968 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 13969 Typ : constant Entity_Id := Etype (N2); 13970 13971 begin 13972 Set_Etype (N, Typ); 13973 13974 -- If the entity of N is not the associated node, this is a 13975 -- nested generic and it has an associated node as well, whose 13976 -- type is already the full view (see below). Indicate that the 13977 -- original node has a private view. 13978 13979 if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then 13980 Set_Has_Private_View (N); 13981 end if; 13982 13983 -- If not a private type, nothing else to do 13984 13985 if not Is_Private_Type (Typ) then 13986 if Is_Array_Type (Typ) 13987 and then Is_Private_Type (Component_Type (Typ)) 13988 then 13989 Set_Has_Private_View (N); 13990 end if; 13991 13992 -- If it is a derivation of a private type in a context where no 13993 -- full view is needed, nothing to do either. 13994 13995 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 13996 null; 13997 13998 -- Otherwise mark the type for flipping and use the full view when 13999 -- available. 14000 14001 else 14002 Set_Has_Private_View (N); 14003 14004 if Present (Full_View (Typ)) then 14005 Set_Etype (N2, Full_View (Typ)); 14006 end if; 14007 end if; 14008 end Set_Global_Type; 14009 14010 ------------------ 14011 -- Top_Ancestor -- 14012 ------------------ 14013 14014 function Top_Ancestor (E : Entity_Id) return Entity_Id is 14015 Par : Entity_Id; 14016 14017 begin 14018 Par := E; 14019 while Is_Child_Unit (Par) loop 14020 Par := Scope (Par); 14021 end loop; 14022 14023 return Par; 14024 end Top_Ancestor; 14025 14026 -- Start of processing for Reset_Entity 14027 14028 begin 14029 N2 := Get_Associated_Node (N); 14030 E := Entity (N2); 14031 14032 if Present (E) then 14033 14034 -- If the node is an entry call to an entry in an enclosing task, 14035 -- it is rewritten as a selected component. No global entity to 14036 -- preserve in this case, since the expansion will be redone in 14037 -- the instance. 14038 14039 if not Nkind_In (E, N_Defining_Character_Literal, 14040 N_Defining_Identifier, 14041 N_Defining_Operator_Symbol) 14042 then 14043 Set_Associated_Node (N, Empty); 14044 Set_Etype (N, Empty); 14045 return; 14046 end if; 14047 14048 -- If the entity is an itype created as a subtype of an access 14049 -- type with a null exclusion restore source entity for proper 14050 -- visibility. The itype will be created anew in the instance. 14051 14052 if Is_Itype (E) 14053 and then Ekind (E) = E_Access_Subtype 14054 and then Is_Entity_Name (N) 14055 and then Chars (Etype (E)) = Chars (N) 14056 then 14057 E := Etype (E); 14058 Set_Entity (N2, E); 14059 Set_Etype (N2, E); 14060 end if; 14061 14062 if Is_Global (E) then 14063 14064 -- If the entity is a package renaming that is the prefix of 14065 -- an expanded name, it has been rewritten as the renamed 14066 -- package, which is necessary semantically but complicates 14067 -- ASIS tree traversal, so we recover the original entity to 14068 -- expose the renaming. Take into account that the context may 14069 -- be a nested generic, that the original node may itself have 14070 -- an associated node that had better be an entity, and that 14071 -- the current node is still a selected component. 14072 14073 if Ekind (E) = E_Package 14074 and then Nkind (N) = N_Selected_Component 14075 and then Nkind (Parent (N)) = N_Expanded_Name 14076 and then Present (Original_Node (N2)) 14077 and then Is_Entity_Name (Original_Node (N2)) 14078 and then Present (Entity (Original_Node (N2))) 14079 then 14080 if Is_Global (Entity (Original_Node (N2))) then 14081 N2 := Original_Node (N2); 14082 Set_Associated_Node (N, N2); 14083 Set_Global_Type (N, N2); 14084 14085 -- Renaming is local, and will be resolved in instance 14086 14087 else 14088 Set_Associated_Node (N, Empty); 14089 Set_Etype (N, Empty); 14090 end if; 14091 14092 else 14093 Set_Global_Type (N, N2); 14094 end if; 14095 14096 elsif Nkind (N) = N_Op_Concat 14097 and then Is_Generic_Type (Etype (N2)) 14098 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 14099 or else 14100 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 14101 and then Is_Intrinsic_Subprogram (E) 14102 then 14103 null; 14104 14105 -- Entity is local. Mark generic node as unresolved. Note that now 14106 -- it does not have an entity. 14107 14108 else 14109 Set_Associated_Node (N, Empty); 14110 Set_Etype (N, Empty); 14111 end if; 14112 14113 if Nkind (Parent (N)) in N_Generic_Instantiation 14114 and then N = Name (Parent (N)) 14115 then 14116 Save_Global_Defaults (Parent (N), Parent (N2)); 14117 end if; 14118 14119 elsif Nkind (Parent (N)) = N_Selected_Component 14120 and then Nkind (Parent (N2)) = N_Expanded_Name 14121 then 14122 if Is_Global (Entity (Parent (N2))) then 14123 Change_Selected_Component_To_Expanded_Name (Parent (N)); 14124 Set_Associated_Node (Parent (N), Parent (N2)); 14125 Set_Global_Type (Parent (N), Parent (N2)); 14126 Save_Entity_Descendants (N); 14127 14128 -- If this is a reference to the current generic entity, replace 14129 -- by the name of the generic homonym of the current package. This 14130 -- is because in an instantiation Par.P.Q will not resolve to the 14131 -- name of the instance, whose enclosing scope is not necessarily 14132 -- Par. We use the generic homonym rather that the name of the 14133 -- generic itself because it may be hidden by a local declaration. 14134 14135 elsif In_Open_Scopes (Entity (Parent (N2))) 14136 and then not 14137 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 14138 then 14139 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 14140 Rewrite (Parent (N), 14141 Make_Identifier (Sloc (N), 14142 Chars => 14143 Chars (Generic_Homonym (Entity (Parent (N2)))))); 14144 else 14145 Rewrite (Parent (N), 14146 Make_Identifier (Sloc (N), 14147 Chars => Chars (Selector_Name (Parent (N2))))); 14148 end if; 14149 end if; 14150 14151 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 14152 and then Parent (N) = Name (Parent (Parent (N))) 14153 then 14154 Save_Global_Defaults 14155 (Parent (Parent (N)), Parent (Parent (N2))); 14156 end if; 14157 14158 -- A selected component may denote a static constant that has been 14159 -- folded. If the static constant is global to the generic, capture 14160 -- its value. Otherwise the folding will happen in any instantiation. 14161 14162 elsif Nkind (Parent (N)) = N_Selected_Component 14163 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 14164 then 14165 if Present (Entity (Original_Node (Parent (N2)))) 14166 and then Is_Global (Entity (Original_Node (Parent (N2)))) 14167 then 14168 Rewrite (Parent (N), New_Copy (Parent (N2))); 14169 Set_Analyzed (Parent (N), False); 14170 end if; 14171 14172 -- A selected component may be transformed into a parameterless 14173 -- function call. If the called entity is global, rewrite the node 14174 -- appropriately, i.e. as an extended name for the global entity. 14175 14176 elsif Nkind (Parent (N)) = N_Selected_Component 14177 and then Nkind (Parent (N2)) = N_Function_Call 14178 and then N = Selector_Name (Parent (N)) 14179 then 14180 if No (Parameter_Associations (Parent (N2))) then 14181 if Is_Global (Entity (Name (Parent (N2)))) then 14182 Change_Selected_Component_To_Expanded_Name (Parent (N)); 14183 Set_Associated_Node (Parent (N), Name (Parent (N2))); 14184 Set_Global_Type (Parent (N), Name (Parent (N2))); 14185 Save_Entity_Descendants (N); 14186 14187 else 14188 Set_Is_Prefixed_Call (Parent (N)); 14189 Set_Associated_Node (N, Empty); 14190 Set_Etype (N, Empty); 14191 end if; 14192 14193 -- In Ada 2005, X.F may be a call to a primitive operation, 14194 -- rewritten as F (X). This rewriting will be done again in an 14195 -- instance, so keep the original node. Global entities will be 14196 -- captured as for other constructs. Indicate that this must 14197 -- resolve as a call, to prevent accidental overloading in the 14198 -- instance, if both a component and a primitive operation appear 14199 -- as candidates. 14200 14201 else 14202 Set_Is_Prefixed_Call (Parent (N)); 14203 end if; 14204 14205 -- Entity is local. Reset in generic unit, so that node is resolved 14206 -- anew at the point of instantiation. 14207 14208 else 14209 Set_Associated_Node (N, Empty); 14210 Set_Etype (N, Empty); 14211 end if; 14212 end Reset_Entity; 14213 14214 ----------------------------- 14215 -- Save_Entity_Descendants -- 14216 ----------------------------- 14217 14218 procedure Save_Entity_Descendants (N : Node_Id) is 14219 begin 14220 case Nkind (N) is 14221 when N_Binary_Op => 14222 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 14223 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 14224 14225 when N_Unary_Op => 14226 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 14227 14228 when N_Expanded_Name | 14229 N_Selected_Component => 14230 Save_Global_Descendant (Union_Id (Prefix (N))); 14231 Save_Global_Descendant (Union_Id (Selector_Name (N))); 14232 14233 when N_Identifier | 14234 N_Character_Literal | 14235 N_Operator_Symbol => 14236 null; 14237 14238 when others => 14239 raise Program_Error; 14240 end case; 14241 end Save_Entity_Descendants; 14242 14243 -------------------------- 14244 -- Save_Global_Defaults -- 14245 -------------------------- 14246 14247 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id) is 14248 Loc : constant Source_Ptr := Sloc (N1); 14249 Assoc2 : constant List_Id := Generic_Associations (N2); 14250 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 14251 Assoc1 : List_Id; 14252 Act1 : Node_Id; 14253 Act2 : Node_Id; 14254 Def : Node_Id; 14255 Ndec : Node_Id; 14256 Subp : Entity_Id; 14257 Actual : Entity_Id; 14258 14259 begin 14260 Assoc1 := Generic_Associations (N1); 14261 14262 if Present (Assoc1) then 14263 Act1 := First (Assoc1); 14264 else 14265 Act1 := Empty; 14266 Set_Generic_Associations (N1, New_List); 14267 Assoc1 := Generic_Associations (N1); 14268 end if; 14269 14270 if Present (Assoc2) then 14271 Act2 := First (Assoc2); 14272 else 14273 return; 14274 end if; 14275 14276 while Present (Act1) and then Present (Act2) loop 14277 Next (Act1); 14278 Next (Act2); 14279 end loop; 14280 14281 -- Find the associations added for default subprograms 14282 14283 if Present (Act2) then 14284 while Nkind (Act2) /= N_Generic_Association 14285 or else No (Entity (Selector_Name (Act2))) 14286 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 14287 loop 14288 Next (Act2); 14289 end loop; 14290 14291 -- Add a similar association if the default is global. The 14292 -- renaming declaration for the actual has been analyzed, and 14293 -- its alias is the program it renames. Link the actual in the 14294 -- original generic tree with the node in the analyzed tree. 14295 14296 while Present (Act2) loop 14297 Subp := Entity (Selector_Name (Act2)); 14298 Def := Explicit_Generic_Actual_Parameter (Act2); 14299 14300 -- Following test is defence against rubbish errors 14301 14302 if No (Alias (Subp)) then 14303 return; 14304 end if; 14305 14306 -- Retrieve the resolved actual from the renaming declaration 14307 -- created for the instantiated formal. 14308 14309 Actual := Entity (Name (Parent (Parent (Subp)))); 14310 Set_Entity (Def, Actual); 14311 Set_Etype (Def, Etype (Actual)); 14312 14313 if Is_Global (Actual) then 14314 Ndec := 14315 Make_Generic_Association (Loc, 14316 Selector_Name => 14317 New_Occurrence_Of (Subp, Loc), 14318 Explicit_Generic_Actual_Parameter => 14319 New_Occurrence_Of (Actual, Loc)); 14320 14321 Set_Associated_Node 14322 (Explicit_Generic_Actual_Parameter (Ndec), Def); 14323 14324 Append (Ndec, Assoc1); 14325 14326 -- If there are other defaults, add a dummy association in case 14327 -- there are other defaulted formals with the same name. 14328 14329 elsif Present (Next (Act2)) then 14330 Ndec := 14331 Make_Generic_Association (Loc, 14332 Selector_Name => 14333 New_Occurrence_Of (Subp, Loc), 14334 Explicit_Generic_Actual_Parameter => Empty); 14335 14336 Append (Ndec, Assoc1); 14337 end if; 14338 14339 Next (Act2); 14340 end loop; 14341 end if; 14342 14343 if Nkind (Name (N1)) = N_Identifier 14344 and then Is_Child_Unit (Gen_Id) 14345 and then Is_Global (Gen_Id) 14346 and then Is_Generic_Unit (Scope (Gen_Id)) 14347 and then In_Open_Scopes (Scope (Gen_Id)) 14348 then 14349 -- This is an instantiation of a child unit within a sibling, so 14350 -- that the generic parent is in scope. An eventual instance must 14351 -- occur within the scope of an instance of the parent. Make name 14352 -- in instance into an expanded name, to preserve the identifier 14353 -- of the parent, so it can be resolved subsequently. 14354 14355 Rewrite (Name (N2), 14356 Make_Expanded_Name (Loc, 14357 Chars => Chars (Gen_Id), 14358 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 14359 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 14360 Set_Entity (Name (N2), Gen_Id); 14361 14362 Rewrite (Name (N1), 14363 Make_Expanded_Name (Loc, 14364 Chars => Chars (Gen_Id), 14365 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 14366 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 14367 14368 Set_Associated_Node (Name (N1), Name (N2)); 14369 Set_Associated_Node (Prefix (Name (N1)), Empty); 14370 Set_Associated_Node 14371 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 14372 Set_Etype (Name (N1), Etype (Gen_Id)); 14373 end if; 14374 end Save_Global_Defaults; 14375 14376 ---------------------------- 14377 -- Save_Global_Descendant -- 14378 ---------------------------- 14379 14380 procedure Save_Global_Descendant (D : Union_Id) is 14381 N1 : Node_Id; 14382 14383 begin 14384 if D in Node_Range then 14385 if D = Union_Id (Empty) then 14386 null; 14387 14388 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 14389 Save_References (Node_Id (D)); 14390 end if; 14391 14392 elsif D in List_Range then 14393 if D = Union_Id (No_List) or else Is_Empty_List (List_Id (D)) then 14394 null; 14395 14396 else 14397 N1 := First (List_Id (D)); 14398 while Present (N1) loop 14399 Save_References (N1); 14400 Next (N1); 14401 end loop; 14402 end if; 14403 14404 -- Element list or other non-node field, nothing to do 14405 14406 else 14407 null; 14408 end if; 14409 end Save_Global_Descendant; 14410 14411 --------------------- 14412 -- Save_References -- 14413 --------------------- 14414 14415 -- This is the recursive procedure that does the work once the enclosing 14416 -- generic scope has been established. We have to treat specially a 14417 -- number of node rewritings that are required by semantic processing 14418 -- and which change the kind of nodes in the generic copy: typically 14419 -- constant-folding, replacing an operator node by a string literal, or 14420 -- a selected component by an expanded name. In each of those cases, the 14421 -- transformation is propagated to the generic unit. 14422 14423 procedure Save_References (N : Node_Id) is 14424 Loc : constant Source_Ptr := Sloc (N); 14425 14426 function Requires_Delayed_Save (Nod : Node_Id) return Boolean; 14427 -- Determine whether arbitrary node Nod requires delayed capture of 14428 -- global references within its aspect specifications. 14429 14430 procedure Save_References_In_Aggregate (N : Node_Id); 14431 -- Save all global references in [extension] aggregate node N 14432 14433 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id); 14434 -- Save all global references in a character literal or operator 14435 -- symbol denoted by N. 14436 14437 procedure Save_References_In_Descendants (N : Node_Id); 14438 -- Save all global references in all descendants of node N 14439 14440 procedure Save_References_In_Identifier (N : Node_Id); 14441 -- Save all global references in identifier node N 14442 14443 procedure Save_References_In_Operator (N : Node_Id); 14444 -- Save all global references in operator node N 14445 14446 procedure Save_References_In_Pragma (Prag : Node_Id); 14447 -- Save all global references found within the expression of pragma 14448 -- Prag. 14449 14450 --------------------------- 14451 -- Requires_Delayed_Save -- 14452 --------------------------- 14453 14454 function Requires_Delayed_Save (Nod : Node_Id) return Boolean is 14455 begin 14456 -- Generic packages and subprograms require delayed capture of 14457 -- global references within their aspects due to the timing of 14458 -- annotation analysis. 14459 14460 if Nkind_In (Nod, N_Generic_Package_Declaration, 14461 N_Generic_Subprogram_Declaration, 14462 N_Package_Body, 14463 N_Package_Body_Stub, 14464 N_Subprogram_Body, 14465 N_Subprogram_Body_Stub) 14466 then 14467 -- Since the capture of global references is done on the 14468 -- unanalyzed generic template, there is no information around 14469 -- to infer the context. Use the Associated_Entity linkages to 14470 -- peek into the analyzed generic copy and determine what the 14471 -- template corresponds to. 14472 14473 if Nod = Templ then 14474 return 14475 Is_Generic_Declaration_Or_Body 14476 (Unit_Declaration_Node 14477 (Associated_Entity (Defining_Entity (Nod)))); 14478 14479 -- Otherwise the generic unit being processed is not the top 14480 -- level template. It is safe to capture of global references 14481 -- within the generic unit because at this point the top level 14482 -- copy is fully analyzed. 14483 14484 else 14485 return False; 14486 end if; 14487 14488 -- Otherwise capture the global references without interference 14489 14490 else 14491 return False; 14492 end if; 14493 end Requires_Delayed_Save; 14494 14495 ---------------------------------- 14496 -- Save_References_In_Aggregate -- 14497 ---------------------------------- 14498 14499 procedure Save_References_In_Aggregate (N : Node_Id) is 14500 Nam : Node_Id; 14501 Qual : Node_Id := Empty; 14502 Typ : Entity_Id := Empty; 14503 14504 use Atree.Unchecked_Access; 14505 -- This code section is part of implementing an untyped tree 14506 -- traversal, so it needs direct access to node fields. 14507 14508 begin 14509 N2 := Get_Associated_Node (N); 14510 14511 if Present (N2) then 14512 Typ := Etype (N2); 14513 14514 -- In an instance within a generic, use the name of the actual 14515 -- and not the original generic parameter. If the actual is 14516 -- global in the current generic it must be preserved for its 14517 -- instantiation. 14518 14519 if Nkind (Parent (Typ)) = N_Subtype_Declaration 14520 and then Present (Generic_Parent_Type (Parent (Typ))) 14521 then 14522 Typ := Base_Type (Typ); 14523 Set_Etype (N2, Typ); 14524 end if; 14525 end if; 14526 14527 if No (N2) or else No (Typ) or else not Is_Global (Typ) then 14528 Set_Associated_Node (N, Empty); 14529 14530 -- If the aggregate is an actual in a call, it has been 14531 -- resolved in the current context, to some local type. The 14532 -- enclosing call may have been disambiguated by the aggregate, 14533 -- and this disambiguation might fail at instantiation time 14534 -- because the type to which the aggregate did resolve is not 14535 -- preserved. In order to preserve some of this information, 14536 -- wrap the aggregate in a qualified expression, using the id 14537 -- of its type. For further disambiguation we qualify the type 14538 -- name with its scope (if visible) because both id's will have 14539 -- corresponding entities in an instance. This resolves most of 14540 -- the problems with missing type information on aggregates in 14541 -- instances. 14542 14543 if Present (N2) 14544 and then Nkind (N2) = Nkind (N) 14545 and then Nkind (Parent (N2)) in N_Subprogram_Call 14546 and then Present (Typ) 14547 and then Comes_From_Source (Typ) 14548 then 14549 Nam := Make_Identifier (Loc, Chars (Typ)); 14550 14551 if Is_Immediately_Visible (Scope (Typ)) then 14552 Nam := 14553 Make_Selected_Component (Loc, 14554 Prefix => 14555 Make_Identifier (Loc, Chars (Scope (Typ))), 14556 Selector_Name => Nam); 14557 end if; 14558 14559 Qual := 14560 Make_Qualified_Expression (Loc, 14561 Subtype_Mark => Nam, 14562 Expression => Relocate_Node (N)); 14563 end if; 14564 end if; 14565 14566 Save_Global_Descendant (Field1 (N)); 14567 Save_Global_Descendant (Field2 (N)); 14568 Save_Global_Descendant (Field3 (N)); 14569 Save_Global_Descendant (Field5 (N)); 14570 14571 if Present (Qual) then 14572 Rewrite (N, Qual); 14573 end if; 14574 end Save_References_In_Aggregate; 14575 14576 ---------------------------------------------- 14577 -- Save_References_In_Char_Lit_Or_Op_Symbol -- 14578 ---------------------------------------------- 14579 14580 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id) is 14581 begin 14582 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 14583 Reset_Entity (N); 14584 14585 elsif Nkind (N) = N_Operator_Symbol 14586 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 14587 then 14588 Change_Operator_Symbol_To_String_Literal (N); 14589 end if; 14590 end Save_References_In_Char_Lit_Or_Op_Symbol; 14591 14592 ------------------------------------ 14593 -- Save_References_In_Descendants -- 14594 ------------------------------------ 14595 14596 procedure Save_References_In_Descendants (N : Node_Id) is 14597 use Atree.Unchecked_Access; 14598 -- This code section is part of implementing an untyped tree 14599 -- traversal, so it needs direct access to node fields. 14600 14601 begin 14602 Save_Global_Descendant (Field1 (N)); 14603 Save_Global_Descendant (Field2 (N)); 14604 Save_Global_Descendant (Field3 (N)); 14605 Save_Global_Descendant (Field4 (N)); 14606 Save_Global_Descendant (Field5 (N)); 14607 end Save_References_In_Descendants; 14608 14609 ----------------------------------- 14610 -- Save_References_In_Identifier -- 14611 ----------------------------------- 14612 14613 procedure Save_References_In_Identifier (N : Node_Id) is 14614 begin 14615 -- The node did not undergo a transformation 14616 14617 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 14618 14619 -- If this is a discriminant reference, always save it. It is 14620 -- used in the instance to find the corresponding discriminant 14621 -- positionally rather than by name. 14622 14623 Set_Original_Discriminant 14624 (N, Original_Discriminant (Get_Associated_Node (N))); 14625 Reset_Entity (N); 14626 14627 -- The analysis of the generic copy transformed the identifier 14628 -- into another construct. Propagate the changes to the template. 14629 14630 else 14631 N2 := Get_Associated_Node (N); 14632 14633 -- The identifier denotes a call to a parameterless function. 14634 -- Mark the node as resolved when the function is external. 14635 14636 if Nkind (N2) = N_Function_Call then 14637 E := Entity (Name (N2)); 14638 14639 if Present (E) and then Is_Global (E) then 14640 Set_Etype (N, Etype (N2)); 14641 else 14642 Set_Associated_Node (N, Empty); 14643 Set_Etype (N, Empty); 14644 end if; 14645 14646 -- The identifier denotes a named number that was constant 14647 -- folded. Preserve the original name for ASIS and undo the 14648 -- constant folding which will be repeated in the instance. 14649 14650 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 14651 and then Is_Entity_Name (Original_Node (N2)) 14652 then 14653 Set_Associated_Node (N, Original_Node (N2)); 14654 Reset_Entity (N); 14655 14656 -- The identifier resolved to a string literal. Propagate this 14657 -- information to the generic template. 14658 14659 elsif Nkind (N2) = N_String_Literal then 14660 Rewrite (N, New_Copy (N2)); 14661 14662 -- The identifier is rewritten as a dereference if it is the 14663 -- prefix of an implicit dereference. Preserve the original 14664 -- tree as the analysis of the instance will expand the node 14665 -- again, but preserve the resolved entity if it is global. 14666 14667 elsif Nkind (N2) = N_Explicit_Dereference then 14668 if Is_Entity_Name (Prefix (N2)) 14669 and then Present (Entity (Prefix (N2))) 14670 and then Is_Global (Entity (Prefix (N2))) 14671 then 14672 Set_Associated_Node (N, Prefix (N2)); 14673 14674 elsif Nkind (Prefix (N2)) = N_Function_Call 14675 and then Present (Entity (Name (Prefix (N2)))) 14676 and then Is_Global (Entity (Name (Prefix (N2)))) 14677 then 14678 Rewrite (N, 14679 Make_Explicit_Dereference (Loc, 14680 Prefix => 14681 Make_Function_Call (Loc, 14682 Name => 14683 New_Occurrence_Of 14684 (Entity (Name (Prefix (N2))), Loc)))); 14685 14686 else 14687 Set_Associated_Node (N, Empty); 14688 Set_Etype (N, Empty); 14689 end if; 14690 14691 -- The subtype mark of a nominally unconstrained object is 14692 -- rewritten as a subtype indication using the bounds of the 14693 -- expression. Recover the original subtype mark. 14694 14695 elsif Nkind (N2) = N_Subtype_Indication 14696 and then Is_Entity_Name (Original_Node (N2)) 14697 then 14698 Set_Associated_Node (N, Original_Node (N2)); 14699 Reset_Entity (N); 14700 end if; 14701 end if; 14702 end Save_References_In_Identifier; 14703 14704 --------------------------------- 14705 -- Save_References_In_Operator -- 14706 --------------------------------- 14707 14708 procedure Save_References_In_Operator (N : Node_Id) is 14709 begin 14710 -- The node did not undergo a transformation 14711 14712 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 14713 if Nkind (N) = N_Op_Concat then 14714 Set_Is_Component_Left_Opnd (N, 14715 Is_Component_Left_Opnd (Get_Associated_Node (N))); 14716 14717 Set_Is_Component_Right_Opnd (N, 14718 Is_Component_Right_Opnd (Get_Associated_Node (N))); 14719 end if; 14720 14721 Reset_Entity (N); 14722 14723 -- The analysis of the generic copy transformed the operator into 14724 -- some other construct. Propagate the changes to the template. 14725 14726 else 14727 N2 := Get_Associated_Node (N); 14728 14729 -- The operator resoved to a function call 14730 14731 if Nkind (N2) = N_Function_Call then 14732 E := Entity (Name (N2)); 14733 14734 if Present (E) and then Is_Global (E) then 14735 Set_Etype (N, Etype (N2)); 14736 else 14737 Set_Associated_Node (N, Empty); 14738 Set_Etype (N, Empty); 14739 end if; 14740 14741 -- The operator was folded into a literal 14742 14743 elsif Nkind_In (N2, N_Integer_Literal, 14744 N_Real_Literal, 14745 N_String_Literal) 14746 then 14747 if Present (Original_Node (N2)) 14748 and then Nkind (Original_Node (N2)) = Nkind (N) 14749 then 14750 -- Operation was constant-folded. Whenever possible, 14751 -- recover semantic information from unfolded node, 14752 -- for ASIS use. 14753 14754 Set_Associated_Node (N, Original_Node (N2)); 14755 14756 if Nkind (N) = N_Op_Concat then 14757 Set_Is_Component_Left_Opnd (N, 14758 Is_Component_Left_Opnd (Get_Associated_Node (N))); 14759 Set_Is_Component_Right_Opnd (N, 14760 Is_Component_Right_Opnd (Get_Associated_Node (N))); 14761 end if; 14762 14763 Reset_Entity (N); 14764 14765 -- Propagate the constant folding back to the template 14766 14767 else 14768 Rewrite (N, New_Copy (N2)); 14769 Set_Analyzed (N, False); 14770 end if; 14771 14772 -- The operator was folded into an enumeration literal. Retain 14773 -- the entity to avoid spurious ambiguities if it is overloaded 14774 -- at the point of instantiation or inlining. 14775 14776 elsif Nkind (N2) = N_Identifier 14777 and then Ekind (Entity (N2)) = E_Enumeration_Literal 14778 then 14779 Rewrite (N, New_Copy (N2)); 14780 Set_Analyzed (N, False); 14781 end if; 14782 end if; 14783 14784 -- Complete the operands check if node has not been constant 14785 -- folded. 14786 14787 if Nkind (N) in N_Op then 14788 Save_Entity_Descendants (N); 14789 end if; 14790 end Save_References_In_Operator; 14791 14792 ------------------------------- 14793 -- Save_References_In_Pragma -- 14794 ------------------------------- 14795 14796 procedure Save_References_In_Pragma (Prag : Node_Id) is 14797 Context : Node_Id; 14798 Do_Save : Boolean := True; 14799 14800 use Atree.Unchecked_Access; 14801 -- This code section is part of implementing an untyped tree 14802 -- traversal, so it needs direct access to node fields. 14803 14804 begin 14805 -- Do not save global references in pragmas generated from aspects 14806 -- because the pragmas will be regenerated at instantiation time. 14807 14808 if From_Aspect_Specification (Prag) then 14809 Do_Save := False; 14810 14811 -- The capture of global references within contract-related source 14812 -- pragmas associated with generic packages, subprograms or their 14813 -- respective bodies must be delayed due to timing of annotation 14814 -- analysis. Global references are still captured in routine 14815 -- Save_Global_References_In_Contract. 14816 14817 elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then 14818 if Is_Package_Contract_Annotation (Prag) then 14819 Context := Find_Related_Package_Or_Body (Prag); 14820 else 14821 pragma Assert (Is_Subprogram_Contract_Annotation (Prag)); 14822 Context := Find_Related_Declaration_Or_Body (Prag); 14823 end if; 14824 14825 -- The use of Original_Node accounts for the case when the 14826 -- related context is generic template. 14827 14828 if Requires_Delayed_Save (Original_Node (Context)) then 14829 Do_Save := False; 14830 end if; 14831 end if; 14832 14833 -- For all other cases, save all global references within the 14834 -- descendants, but skip the following semantic fields: 14835 14836 -- Field1 - Next_Pragma 14837 -- Field3 - Corresponding_Aspect 14838 -- Field5 - Next_Rep_Item 14839 14840 if Do_Save then 14841 Save_Global_Descendant (Field2 (Prag)); 14842 Save_Global_Descendant (Field4 (Prag)); 14843 end if; 14844 end Save_References_In_Pragma; 14845 14846 -- Start of processing for Save_References 14847 14848 begin 14849 if N = Empty then 14850 null; 14851 14852 -- Aggregates 14853 14854 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 14855 Save_References_In_Aggregate (N); 14856 14857 -- Character literals, operator symbols 14858 14859 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 14860 Save_References_In_Char_Lit_Or_Op_Symbol (N); 14861 14862 -- Defining identifiers 14863 14864 elsif Nkind (N) in N_Entity then 14865 null; 14866 14867 -- Identifiers 14868 14869 elsif Nkind (N) = N_Identifier then 14870 Save_References_In_Identifier (N); 14871 14872 -- Operators 14873 14874 elsif Nkind (N) in N_Op then 14875 Save_References_In_Operator (N); 14876 14877 -- Pragmas 14878 14879 elsif Nkind (N) = N_Pragma then 14880 Save_References_In_Pragma (N); 14881 14882 else 14883 Save_References_In_Descendants (N); 14884 end if; 14885 14886 -- Save all global references found within the aspect specifications 14887 -- of the related node. 14888 14889 if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then 14890 14891 -- The capture of global references within aspects associated with 14892 -- generic packages, subprograms or their bodies must be delayed 14893 -- due to timing of annotation analysis. Global references are 14894 -- still captured in routine Save_Global_References_In_Contract. 14895 14896 if Requires_Delayed_Save (N) then 14897 null; 14898 14899 -- Otherwise save all global references within the aspects 14900 14901 else 14902 Save_Global_References_In_Aspects (N); 14903 end if; 14904 end if; 14905 end Save_References; 14906 14907 -- Start of processing for Save_Global_References 14908 14909 begin 14910 Gen_Scope := Current_Scope; 14911 14912 -- If the generic unit is a child unit, references to entities in the 14913 -- parent are treated as local, because they will be resolved anew in 14914 -- the context of the instance of the parent. 14915 14916 while Is_Child_Unit (Gen_Scope) 14917 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 14918 loop 14919 Gen_Scope := Scope (Gen_Scope); 14920 end loop; 14921 14922 Save_References (Templ); 14923 end Save_Global_References; 14924 14925 --------------------------------------- 14926 -- Save_Global_References_In_Aspects -- 14927 --------------------------------------- 14928 14929 procedure Save_Global_References_In_Aspects (N : Node_Id) is 14930 Asp : Node_Id; 14931 Expr : Node_Id; 14932 14933 begin 14934 Asp := First (Aspect_Specifications (N)); 14935 while Present (Asp) loop 14936 Expr := Expression (Asp); 14937 14938 if Present (Expr) then 14939 Save_Global_References (Expr); 14940 end if; 14941 14942 Next (Asp); 14943 end loop; 14944 end Save_Global_References_In_Aspects; 14945 14946 -------------------------------------- 14947 -- Set_Copied_Sloc_For_Inlined_Body -- 14948 -------------------------------------- 14949 14950 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 14951 begin 14952 Create_Instantiation_Source (N, E, True, S_Adjustment); 14953 end Set_Copied_Sloc_For_Inlined_Body; 14954 14955 --------------------- 14956 -- Set_Instance_Of -- 14957 --------------------- 14958 14959 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 14960 begin 14961 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 14962 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 14963 Generic_Renamings.Increment_Last; 14964 end Set_Instance_Of; 14965 14966 -------------------- 14967 -- Set_Next_Assoc -- 14968 -------------------- 14969 14970 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 14971 begin 14972 Generic_Renamings.Table (E).Next_In_HTable := Next; 14973 end Set_Next_Assoc; 14974 14975 ------------------- 14976 -- Start_Generic -- 14977 ------------------- 14978 14979 procedure Start_Generic is 14980 begin 14981 -- ??? More things could be factored out in this routine. 14982 -- Should probably be done at a later stage. 14983 14984 Generic_Flags.Append (Inside_A_Generic); 14985 Inside_A_Generic := True; 14986 14987 Expander_Mode_Save_And_Set (False); 14988 end Start_Generic; 14989 14990 ---------------------- 14991 -- Set_Instance_Env -- 14992 ---------------------- 14993 14994 procedure Set_Instance_Env 14995 (Gen_Unit : Entity_Id; 14996 Act_Unit : Entity_Id) 14997 is 14998 Assertion_Status : constant Boolean := Assertions_Enabled; 14999 Save_SPARK_Mode : constant SPARK_Mode_Type := SPARK_Mode; 15000 Save_SPARK_Mode_Pragma : constant Node_Id := SPARK_Mode_Pragma; 15001 15002 begin 15003 -- Regardless of the current mode, predefined units are analyzed in the 15004 -- most current Ada mode, and earlier version Ada checks do not apply 15005 -- to predefined units. Nothing needs to be done for non-internal units. 15006 -- These are always analyzed in the current mode. 15007 15008 if Is_Internal_File_Name 15009 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), 15010 Renamings_Included => True) 15011 then 15012 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); 15013 15014 -- In Ada2012 we may want to enable assertions in an instance of a 15015 -- predefined unit, in which case we need to preserve the current 15016 -- setting for the Assertions_Enabled flag. This will become more 15017 -- critical when pre/postconditions are added to predefined units, 15018 -- as is already the case for some numeric libraries. 15019 15020 if Ada_Version >= Ada_2012 then 15021 Assertions_Enabled := Assertion_Status; 15022 end if; 15023 15024 -- SPARK_Mode for an instance is the one applicable at the point of 15025 -- instantiation. 15026 15027 SPARK_Mode := Save_SPARK_Mode; 15028 SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma; 15029 15030 -- Make sure dynamic elaboration checks are off in SPARK Mode 15031 15032 if SPARK_Mode = On then 15033 Dynamic_Elaboration_Checks := False; 15034 end if; 15035 end if; 15036 15037 Current_Instantiated_Parent := 15038 (Gen_Id => Gen_Unit, 15039 Act_Id => Act_Unit, 15040 Next_In_HTable => Assoc_Null); 15041 end Set_Instance_Env; 15042 15043 ----------------- 15044 -- Switch_View -- 15045 ----------------- 15046 15047 procedure Switch_View (T : Entity_Id) is 15048 BT : constant Entity_Id := Base_Type (T); 15049 Priv_Elmt : Elmt_Id := No_Elmt; 15050 Priv_Sub : Entity_Id; 15051 15052 begin 15053 -- T may be private but its base type may have been exchanged through 15054 -- some other occurrence, in which case there is nothing to switch 15055 -- besides T itself. Note that a private dependent subtype of a private 15056 -- type might not have been switched even if the base type has been, 15057 -- because of the last branch of Check_Private_View (see comment there). 15058 15059 if not Is_Private_Type (BT) then 15060 Prepend_Elmt (Full_View (T), Exchanged_Views); 15061 Exchange_Declarations (T); 15062 return; 15063 end if; 15064 15065 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 15066 15067 if Present (Full_View (BT)) then 15068 Prepend_Elmt (Full_View (BT), Exchanged_Views); 15069 Exchange_Declarations (BT); 15070 end if; 15071 15072 while Present (Priv_Elmt) loop 15073 Priv_Sub := (Node (Priv_Elmt)); 15074 15075 -- We avoid flipping the subtype if the Etype of its full view is 15076 -- private because this would result in a malformed subtype. This 15077 -- occurs when the Etype of the subtype full view is the full view of 15078 -- the base type (and since the base types were just switched, the 15079 -- subtype is pointing to the wrong view). This is currently the case 15080 -- for tagged record types, access types (maybe more?) and needs to 15081 -- be resolved. ??? 15082 15083 if Present (Full_View (Priv_Sub)) 15084 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 15085 then 15086 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 15087 Exchange_Declarations (Priv_Sub); 15088 end if; 15089 15090 Next_Elmt (Priv_Elmt); 15091 end loop; 15092 end Switch_View; 15093 15094 ----------------- 15095 -- True_Parent -- 15096 ----------------- 15097 15098 function True_Parent (N : Node_Id) return Node_Id is 15099 begin 15100 if Nkind (Parent (N)) = N_Subunit then 15101 return Parent (Corresponding_Stub (Parent (N))); 15102 else 15103 return Parent (N); 15104 end if; 15105 end True_Parent; 15106 15107 ----------------------------- 15108 -- Valid_Default_Attribute -- 15109 ----------------------------- 15110 15111 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 15112 Attr_Id : constant Attribute_Id := 15113 Get_Attribute_Id (Attribute_Name (Def)); 15114 T : constant Entity_Id := Entity (Prefix (Def)); 15115 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 15116 F : Entity_Id; 15117 Num_F : Int; 15118 OK : Boolean; 15119 15120 begin 15121 if No (T) or else T = Any_Id then 15122 return; 15123 end if; 15124 15125 Num_F := 0; 15126 F := First_Formal (Nam); 15127 while Present (F) loop 15128 Num_F := Num_F + 1; 15129 Next_Formal (F); 15130 end loop; 15131 15132 case Attr_Id is 15133 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign | 15134 Attribute_Floor | Attribute_Fraction | Attribute_Machine | 15135 Attribute_Model | Attribute_Remainder | Attribute_Rounding | 15136 Attribute_Unbiased_Rounding => 15137 OK := Is_Fun 15138 and then Num_F = 1 15139 and then Is_Floating_Point_Type (T); 15140 15141 when Attribute_Image | Attribute_Pred | Attribute_Succ | 15142 Attribute_Value | Attribute_Wide_Image | 15143 Attribute_Wide_Value => 15144 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T)); 15145 15146 when Attribute_Max | Attribute_Min => 15147 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T)); 15148 15149 when Attribute_Input => 15150 OK := (Is_Fun and then Num_F = 1); 15151 15152 when Attribute_Output | Attribute_Read | Attribute_Write => 15153 OK := (not Is_Fun and then Num_F = 2); 15154 15155 when others => 15156 OK := False; 15157 end case; 15158 15159 if not OK then 15160 Error_Msg_N 15161 ("attribute reference has wrong profile for subprogram", Def); 15162 end if; 15163 end Valid_Default_Attribute; 15164 15165end Sem_Ch12; 15166