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-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 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. This rather complex machinery is 717 -- needed when nested instantiations are present, because the source does 718 -- not carry any indication of where the corresponding instance bodies must 719 -- be installed and frozen. 720 721 procedure Install_Formal_Packages (Par : Entity_Id); 722 -- Install the visible part of any formal of the parent that is a formal 723 -- package. Note that for the case of a formal package with a box, this 724 -- includes the formal part of the formal package (12.7(10/2)). 725 726 procedure Install_Hidden_Primitives 727 (Prims_List : in out Elist_Id; 728 Gen_T : Entity_Id; 729 Act_T : Entity_Id); 730 -- Remove suffix 'P' from hidden primitives of Act_T to match the 731 -- visibility of primitives of Gen_T. The list of primitives to which 732 -- the suffix is removed is added to Prims_List to restore them later. 733 734 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 735 -- When compiling an instance of a child unit the parent (which is 736 -- itself an instance) is an enclosing scope that must be made 737 -- immediately visible. This procedure is also used to install the non- 738 -- generic parent of a generic child unit when compiling its body, so 739 -- that full views of types in the parent are made visible. 740 741 -- The functions Instantiate_XXX perform various legality checks and build 742 -- the declarations for instantiated generic parameters. In all of these 743 -- Formal is the entity in the generic unit, Actual is the entity of 744 -- expression in the generic associations, and Analyzed_Formal is the 745 -- formal in the generic copy, which contains the semantic information to 746 -- be used to validate the actual. 747 748 function Instantiate_Object 749 (Formal : Node_Id; 750 Actual : Node_Id; 751 Analyzed_Formal : Node_Id) return List_Id; 752 753 function Instantiate_Type 754 (Formal : Node_Id; 755 Actual : Node_Id; 756 Analyzed_Formal : Node_Id; 757 Actual_Decls : List_Id) return List_Id; 758 759 function Instantiate_Formal_Subprogram 760 (Formal : Node_Id; 761 Actual : Node_Id; 762 Analyzed_Formal : Node_Id) return Node_Id; 763 764 function Instantiate_Formal_Package 765 (Formal : Node_Id; 766 Actual : Node_Id; 767 Analyzed_Formal : Node_Id) return List_Id; 768 -- If the formal package is declared with a box, special visibility rules 769 -- apply to its formals: they are in the visible part of the package. This 770 -- is true in the declarative region of the formal package, that is to say 771 -- in the enclosing generic or instantiation. For an instantiation, the 772 -- parameters of the formal package are made visible in an explicit step. 773 -- Furthermore, if the actual has a visible USE clause, these formals must 774 -- be made potentially use-visible as well. On exit from the enclosing 775 -- instantiation, the reverse must be done. 776 777 -- For a formal package declared without a box, there are conformance rules 778 -- that apply to the actuals in the generic declaration and the actuals of 779 -- the actual package in the enclosing instantiation. The simplest way to 780 -- apply these rules is to repeat the instantiation of the formal package 781 -- in the context of the enclosing instance, and compare the generic 782 -- associations of this instantiation with those of the actual package. 783 -- This internal instantiation only needs to contain the renamings of the 784 -- formals: the visible and private declarations themselves need not be 785 -- created. 786 787 -- In Ada 2005, the formal package may be only partially parameterized. 788 -- In that case the visibility step must make visible those actuals whose 789 -- corresponding formals were given with a box. A final complication 790 -- involves inherited operations from formal derived types, which must 791 -- be visible if the type is. 792 793 function Is_In_Main_Unit (N : Node_Id) return Boolean; 794 -- Test if given node is in the main unit 795 796 procedure Load_Parent_Of_Generic 797 (N : Node_Id; 798 Spec : Node_Id; 799 Body_Optional : Boolean := False); 800 -- If the generic appears in a separate non-generic library unit, load the 801 -- corresponding body to retrieve the body of the generic. N is the node 802 -- for the generic instantiation, Spec is the generic package declaration. 803 -- 804 -- Body_Optional is a flag that indicates that the body is being loaded to 805 -- ensure that temporaries are generated consistently when there are other 806 -- instances in the current declarative part that precede the one being 807 -- loaded. In that case a missing body is acceptable. 808 809 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 810 -- Within the generic part, entities in the formal package are 811 -- visible. To validate subsequent type declarations, indicate 812 -- the correspondence between the entities in the analyzed formal, 813 -- and the entities in the actual package. There are three packages 814 -- involved in the instantiation of a formal package: the parent 815 -- generic P1 which appears in the generic declaration, the fake 816 -- instantiation P2 which appears in the analyzed generic, and whose 817 -- visible entities may be used in subsequent formals, and the actual 818 -- P3 in the instance. To validate subsequent formals, me indicate 819 -- that the entities in P2 are mapped into those of P3. The mapping of 820 -- entities has to be done recursively for nested packages. 821 822 procedure Move_Freeze_Nodes 823 (Out_Of : Entity_Id; 824 After : Node_Id; 825 L : List_Id); 826 -- Freeze nodes can be generated in the analysis of a generic unit, but 827 -- will not be seen by the back-end. It is necessary to move those nodes 828 -- to the enclosing scope if they freeze an outer entity. We place them 829 -- at the end of the enclosing generic package, which is semantically 830 -- neutral. 831 832 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty); 833 -- Analyze actuals to perform name resolution. Full resolution is done 834 -- later, when the expected types are known, but names have to be captured 835 -- before installing parents of generics, that are not visible for the 836 -- actuals themselves. 837 -- 838 -- If Inst is present, it is the entity of the package instance. This 839 -- entity is marked as having a limited_view actual when some actual is 840 -- a limited view. This is used to place the instance body properly. 841 842 procedure Provide_Completing_Bodies (N : Node_Id); 843 -- Generate completing bodies for all subprograms found within package or 844 -- subprogram declaration N. 845 846 procedure Remove_Parent (In_Body : Boolean := False); 847 -- Reverse effect after instantiation of child is complete 848 849 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 850 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 851 -- set to No_Elist. 852 853 procedure Set_Instance_Env 854 (Gen_Unit : Entity_Id; 855 Act_Unit : Entity_Id); 856 -- Save current instance on saved environment, to be used to determine 857 -- the global status of entities in nested instances. Part of Save_Env. 858 -- called after verifying that the generic unit is legal for the instance, 859 -- The procedure also examines whether the generic unit is a predefined 860 -- unit, in order to set configuration switches accordingly. As a result 861 -- the procedure must be called after analyzing and freezing the actuals. 862 863 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 864 -- Associate analyzed generic parameter with corresponding instance. Used 865 -- for semantic checks at instantiation time. 866 867 function True_Parent (N : Node_Id) return Node_Id; 868 -- For a subunit, return parent of corresponding stub, else return 869 -- parent of node. 870 871 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 872 -- Verify that an attribute that appears as the default for a formal 873 -- subprogram is a function or procedure with the correct profile. 874 875 ------------------------------------------- 876 -- Data Structures for Generic Renamings -- 877 ------------------------------------------- 878 879 -- The map Generic_Renamings associates generic entities with their 880 -- corresponding actuals. Currently used to validate type instances. It 881 -- will eventually be used for all generic parameters to eliminate the 882 -- need for overload resolution in the instance. 883 884 type Assoc_Ptr is new Int; 885 886 Assoc_Null : constant Assoc_Ptr := -1; 887 888 type Assoc is record 889 Gen_Id : Entity_Id; 890 Act_Id : Entity_Id; 891 Next_In_HTable : Assoc_Ptr; 892 end record; 893 894 package Generic_Renamings is new Table.Table 895 (Table_Component_Type => Assoc, 896 Table_Index_Type => Assoc_Ptr, 897 Table_Low_Bound => 0, 898 Table_Initial => 10, 899 Table_Increment => 100, 900 Table_Name => "Generic_Renamings"); 901 902 -- Variable to hold enclosing instantiation. When the environment is 903 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 904 905 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 906 907 -- Hash table for associations 908 909 HTable_Size : constant := 37; 910 type HTable_Range is range 0 .. HTable_Size - 1; 911 912 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 913 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 914 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 915 function Hash (F : Entity_Id) return HTable_Range; 916 917 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 918 Header_Num => HTable_Range, 919 Element => Assoc, 920 Elmt_Ptr => Assoc_Ptr, 921 Null_Ptr => Assoc_Null, 922 Set_Next => Set_Next_Assoc, 923 Next => Next_Assoc, 924 Key => Entity_Id, 925 Get_Key => Get_Gen_Id, 926 Hash => Hash, 927 Equal => "="); 928 929 Exchanged_Views : Elist_Id; 930 -- This list holds the private views that have been exchanged during 931 -- instantiation to restore the visibility of the generic declaration. 932 -- (see comments above). After instantiation, the current visibility is 933 -- reestablished by means of a traversal of this list. 934 935 Hidden_Entities : Elist_Id; 936 -- This list holds the entities of the current scope that are removed 937 -- from immediate visibility when instantiating a child unit. Their 938 -- visibility is restored in Remove_Parent. 939 940 -- Because instantiations can be recursive, the following must be saved 941 -- on entry and restored on exit from an instantiation (spec or body). 942 -- This is done by the two procedures Save_Env and Restore_Env. For 943 -- package and subprogram instantiations (but not for the body instances) 944 -- the action of Save_Env is done in two steps: Init_Env is called before 945 -- Check_Generic_Child_Unit, because setting the parent instances requires 946 -- that the visibility data structures be properly initialized. Once the 947 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 948 949 Parent_Unit_Visible : Boolean := False; 950 -- Parent_Unit_Visible is used when the generic is a child unit, and 951 -- indicates whether the ultimate parent of the generic is visible in the 952 -- instantiation environment. It is used to reset the visibility of the 953 -- parent at the end of the instantiation (see Remove_Parent). 954 955 Instance_Parent_Unit : Entity_Id := Empty; 956 -- This records the ultimate parent unit of an instance of a generic 957 -- child unit and is used in conjunction with Parent_Unit_Visible to 958 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 959 960 type Instance_Env is record 961 Instantiated_Parent : Assoc; 962 Exchanged_Views : Elist_Id; 963 Hidden_Entities : Elist_Id; 964 Current_Sem_Unit : Unit_Number_Type; 965 Parent_Unit_Visible : Boolean := False; 966 Instance_Parent_Unit : Entity_Id := Empty; 967 Switches : Config_Switches_Type; 968 end record; 969 970 package Instance_Envs is new Table.Table ( 971 Table_Component_Type => Instance_Env, 972 Table_Index_Type => Int, 973 Table_Low_Bound => 0, 974 Table_Initial => 32, 975 Table_Increment => 100, 976 Table_Name => "Instance_Envs"); 977 978 procedure Restore_Private_Views 979 (Pack_Id : Entity_Id; 980 Is_Package : Boolean := True); 981 -- Restore the private views of external types, and unmark the generic 982 -- renamings of actuals, so that they become compatible subtypes again. 983 -- For subprograms, Pack_Id is the package constructed to hold the 984 -- renamings. 985 986 procedure Switch_View (T : Entity_Id); 987 -- Switch the partial and full views of a type and its private 988 -- dependents (i.e. its subtypes and derived types). 989 990 ------------------------------------ 991 -- Structures for Error Reporting -- 992 ------------------------------------ 993 994 Instantiation_Node : Node_Id; 995 -- Used by subprograms that validate instantiation of formal parameters 996 -- where there might be no actual on which to place the error message. 997 -- Also used to locate the instantiation node for generic subunits. 998 999 Instantiation_Error : exception; 1000 -- When there is a semantic error in the generic parameter matching, 1001 -- there is no point in continuing the instantiation, because the 1002 -- number of cascaded errors is unpredictable. This exception aborts 1003 -- the instantiation process altogether. 1004 1005 S_Adjustment : Sloc_Adjustment; 1006 -- Offset created for each node in an instantiation, in order to keep 1007 -- track of the source position of the instantiation in each of its nodes. 1008 -- A subsequent semantic error or warning on a construct of the instance 1009 -- points to both places: the original generic node, and the point of 1010 -- instantiation. See Sinput and Sinput.L for additional details. 1011 1012 ------------------------------------------------------------ 1013 -- Data structure for keeping track when inside a Generic -- 1014 ------------------------------------------------------------ 1015 1016 -- The following table is used to save values of the Inside_A_Generic 1017 -- flag (see spec of Sem) when they are saved by Start_Generic. 1018 1019 package Generic_Flags is new Table.Table ( 1020 Table_Component_Type => Boolean, 1021 Table_Index_Type => Int, 1022 Table_Low_Bound => 0, 1023 Table_Initial => 32, 1024 Table_Increment => 200, 1025 Table_Name => "Generic_Flags"); 1026 1027 --------------------------- 1028 -- Abandon_Instantiation -- 1029 --------------------------- 1030 1031 procedure Abandon_Instantiation (N : Node_Id) is 1032 begin 1033 Error_Msg_N ("\instantiation abandoned!", N); 1034 raise Instantiation_Error; 1035 end Abandon_Instantiation; 1036 1037 -------------------------------- 1038 -- Add_Pending_Instantiation -- 1039 -------------------------------- 1040 1041 procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is 1042 begin 1043 1044 -- Add to the instantiation node and the corresponding unit declaration 1045 -- the current values of global flags to be used when analyzing the 1046 -- instance body. 1047 1048 Pending_Instantiations.Append 1049 ((Inst_Node => Inst, 1050 Act_Decl => Act_Decl, 1051 Expander_Status => Expander_Active, 1052 Current_Sem_Unit => Current_Sem_Unit, 1053 Scope_Suppress => Scope_Suppress, 1054 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 1055 Version => Ada_Version, 1056 Version_Pragma => Ada_Version_Pragma, 1057 Warnings => Save_Warnings, 1058 SPARK_Mode => SPARK_Mode, 1059 SPARK_Mode_Pragma => SPARK_Mode_Pragma)); 1060 end Add_Pending_Instantiation; 1061 1062 ---------------------------------- 1063 -- Adjust_Inherited_Pragma_Sloc -- 1064 ---------------------------------- 1065 1066 procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is 1067 begin 1068 Adjust_Instantiation_Sloc (N, S_Adjustment); 1069 end Adjust_Inherited_Pragma_Sloc; 1070 1071 -------------------------- 1072 -- Analyze_Associations -- 1073 -------------------------- 1074 1075 function Analyze_Associations 1076 (I_Node : Node_Id; 1077 Formals : List_Id; 1078 F_Copy : List_Id) return List_Id 1079 is 1080 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 1081 Assoc_List : constant List_Id := New_List; 1082 Default_Actuals : constant List_Id := New_List; 1083 Gen_Unit : constant Entity_Id := 1084 Defining_Entity (Parent (F_Copy)); 1085 1086 Actuals : List_Id; 1087 Actual : Node_Id; 1088 Analyzed_Formal : Node_Id; 1089 First_Named : Node_Id := Empty; 1090 Formal : Node_Id; 1091 Match : Node_Id; 1092 Named : Node_Id; 1093 Saved_Formal : Node_Id; 1094 1095 Default_Formals : constant List_Id := New_List; 1096 -- If an Others_Choice is present, some of the formals may be defaulted. 1097 -- To simplify the treatment of visibility in an instance, we introduce 1098 -- individual defaults for each such formal. These defaults are 1099 -- appended to the list of associations and replace the Others_Choice. 1100 1101 Found_Assoc : Node_Id; 1102 -- Association for the current formal being match. Empty if there are 1103 -- no remaining actuals, or if there is no named association with the 1104 -- name of the formal. 1105 1106 Is_Named_Assoc : Boolean; 1107 Num_Matched : Nat := 0; 1108 Num_Actuals : Nat := 0; 1109 1110 Others_Present : Boolean := False; 1111 Others_Choice : Node_Id := Empty; 1112 -- In Ada 2005, indicates partial parameterization of a formal 1113 -- package. As usual an other association must be last in the list. 1114 1115 procedure Check_Fixed_Point_Actual (Actual : Node_Id); 1116 -- Warn if an actual fixed-point type has user-defined arithmetic 1117 -- operations, but there is no corresponding formal in the generic, 1118 -- in which case the predefined operations will be used. This merits 1119 -- a warning because of the special semantics of fixed point ops. 1120 1121 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 1122 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance 1123 -- cannot have a named association for it. AI05-0025 extends this rule 1124 -- to formals of formal packages by AI05-0025, and it also applies to 1125 -- box-initialized formals. 1126 1127 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 1128 -- Determine whether the parameter types and the return type of Subp 1129 -- are fully defined at the point of instantiation. 1130 1131 function Matching_Actual 1132 (F : Entity_Id; 1133 A_F : Entity_Id) return Node_Id; 1134 -- Find actual that corresponds to a given a formal parameter. If the 1135 -- actuals are positional, return the next one, if any. If the actuals 1136 -- are named, scan the parameter associations to find the right one. 1137 -- A_F is the corresponding entity in the analyzed generic, which is 1138 -- placed on the selector name for ASIS use. 1139 -- 1140 -- In Ada 2005, a named association may be given with a box, in which 1141 -- case Matching_Actual sets Found_Assoc to the generic association, 1142 -- but return Empty for the actual itself. In this case the code below 1143 -- creates a corresponding declaration for the formal. 1144 1145 function Partial_Parameterization return Boolean; 1146 -- Ada 2005: if no match is found for a given formal, check if the 1147 -- association for it includes a box, or whether the associations 1148 -- include an Others clause. 1149 1150 procedure Process_Default (F : Entity_Id); 1151 -- Add a copy of the declaration of generic formal F to the list of 1152 -- associations, and add an explicit box association for F if there 1153 -- is none yet, and the default comes from an Others_Choice. 1154 1155 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 1156 -- Determine whether Subp renames one of the subprograms defined in the 1157 -- generated package Standard. 1158 1159 procedure Set_Analyzed_Formal; 1160 -- Find the node in the generic copy that corresponds to a given formal. 1161 -- The semantic information on this node is used to perform legality 1162 -- checks on the actuals. Because semantic analysis can introduce some 1163 -- anonymous entities or modify the declaration node itself, the 1164 -- correspondence between the two lists is not one-one. In addition to 1165 -- anonymous types, the presence a formal equality will introduce an 1166 -- implicit declaration for the corresponding inequality. 1167 1168 ---------------------------------------- 1169 -- Check_Overloaded_Formal_Subprogram -- 1170 ---------------------------------------- 1171 1172 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1173 Temp_Formal : Entity_Id; 1174 1175 begin 1176 Temp_Formal := First (Formals); 1177 while Present (Temp_Formal) loop 1178 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1179 and then Temp_Formal /= Formal 1180 and then 1181 Chars (Defining_Unit_Name (Specification (Formal))) = 1182 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1183 then 1184 if Present (Found_Assoc) then 1185 Error_Msg_N 1186 ("named association not allowed for overloaded formal", 1187 Found_Assoc); 1188 1189 else 1190 Error_Msg_N 1191 ("named association not allowed for overloaded formal", 1192 Others_Choice); 1193 end if; 1194 1195 Abandon_Instantiation (Instantiation_Node); 1196 end if; 1197 1198 Next (Temp_Formal); 1199 end loop; 1200 end Check_Overloaded_Formal_Subprogram; 1201 1202 ------------------------------- 1203 -- Check_Fixed_Point_Actual -- 1204 ------------------------------- 1205 1206 procedure Check_Fixed_Point_Actual (Actual : Node_Id) is 1207 Typ : constant Entity_Id := Entity (Actual); 1208 Prims : constant Elist_Id := Collect_Primitive_Operations (Typ); 1209 Elem : Elmt_Id; 1210 Formal : Node_Id; 1211 Op : Entity_Id; 1212 1213 begin 1214 -- Locate primitive operations of the type that are arithmetic 1215 -- operations. 1216 1217 Elem := First_Elmt (Prims); 1218 while Present (Elem) loop 1219 if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then 1220 1221 -- Check whether the generic unit has a formal subprogram of 1222 -- the same name. This does not check types but is good enough 1223 -- to justify a warning. 1224 1225 Formal := First_Non_Pragma (Formals); 1226 Op := Alias (Node (Elem)); 1227 1228 while Present (Formal) loop 1229 if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration 1230 and then Chars (Defining_Entity (Formal)) = 1231 Chars (Node (Elem)) 1232 then 1233 exit; 1234 1235 elsif Nkind (Formal) = N_Formal_Package_Declaration then 1236 declare 1237 Assoc : Node_Id; 1238 Ent : Entity_Id; 1239 1240 begin 1241 -- Locate corresponding actual, and check whether it 1242 -- includes a fixed-point type. 1243 1244 Assoc := First (Assoc_List); 1245 while Present (Assoc) loop 1246 exit when 1247 Nkind (Assoc) = N_Package_Renaming_Declaration 1248 and then Chars (Defining_Unit_Name (Assoc)) = 1249 Chars (Defining_Identifier (Formal)); 1250 1251 Next (Assoc); 1252 end loop; 1253 1254 if Present (Assoc) then 1255 1256 -- If formal package declares a fixed-point type, 1257 -- and the user-defined operator is derived from 1258 -- a generic instance package, the fixed-point type 1259 -- does not use the corresponding predefined op. 1260 1261 Ent := First_Entity (Entity (Name (Assoc))); 1262 while Present (Ent) loop 1263 if Is_Fixed_Point_Type (Ent) 1264 and then Present (Op) 1265 and then Is_Generic_Instance (Scope (Op)) 1266 then 1267 return; 1268 end if; 1269 1270 Next_Entity (Ent); 1271 end loop; 1272 end if; 1273 end; 1274 end if; 1275 1276 Next (Formal); 1277 end loop; 1278 1279 if No (Formal) then 1280 Error_Msg_Sloc := Sloc (Node (Elem)); 1281 Error_Msg_NE 1282 ("?instance uses predefined operation, not primitive " 1283 & "operation&#", Actual, Node (Elem)); 1284 end if; 1285 end if; 1286 1287 Next_Elmt (Elem); 1288 end loop; 1289 end Check_Fixed_Point_Actual; 1290 1291 ------------------------------- 1292 -- Has_Fully_Defined_Profile -- 1293 ------------------------------- 1294 1295 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1296 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1297 -- Determine whethet type Typ is fully defined 1298 1299 --------------------------- 1300 -- Is_Fully_Defined_Type -- 1301 --------------------------- 1302 1303 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1304 begin 1305 -- A private type without a full view is not fully defined 1306 1307 if Is_Private_Type (Typ) 1308 and then No (Full_View (Typ)) 1309 then 1310 return False; 1311 1312 -- An incomplete type is never fully defined 1313 1314 elsif Is_Incomplete_Type (Typ) then 1315 return False; 1316 1317 -- All other types are fully defined 1318 1319 else 1320 return True; 1321 end if; 1322 end Is_Fully_Defined_Type; 1323 1324 -- Local declarations 1325 1326 Param : Entity_Id; 1327 1328 -- Start of processing for Has_Fully_Defined_Profile 1329 1330 begin 1331 -- Check the parameters 1332 1333 Param := First_Formal (Subp); 1334 while Present (Param) loop 1335 if not Is_Fully_Defined_Type (Etype (Param)) then 1336 return False; 1337 end if; 1338 1339 Next_Formal (Param); 1340 end loop; 1341 1342 -- Check the return type 1343 1344 return Is_Fully_Defined_Type (Etype (Subp)); 1345 end Has_Fully_Defined_Profile; 1346 1347 --------------------- 1348 -- Matching_Actual -- 1349 --------------------- 1350 1351 function Matching_Actual 1352 (F : Entity_Id; 1353 A_F : Entity_Id) return Node_Id 1354 is 1355 Prev : Node_Id; 1356 Act : Node_Id; 1357 1358 begin 1359 Is_Named_Assoc := False; 1360 1361 -- End of list of purely positional parameters 1362 1363 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1364 Found_Assoc := Empty; 1365 Act := Empty; 1366 1367 -- Case of positional parameter corresponding to current formal 1368 1369 elsif No (Selector_Name (Actual)) then 1370 Found_Assoc := Actual; 1371 Act := Explicit_Generic_Actual_Parameter (Actual); 1372 Num_Matched := Num_Matched + 1; 1373 Next (Actual); 1374 1375 -- Otherwise scan list of named actuals to find the one with the 1376 -- desired name. All remaining actuals have explicit names. 1377 1378 else 1379 Is_Named_Assoc := True; 1380 Found_Assoc := Empty; 1381 Act := Empty; 1382 Prev := Empty; 1383 1384 while Present (Actual) loop 1385 if Nkind (Actual) = N_Others_Choice then 1386 Found_Assoc := Empty; 1387 Act := Empty; 1388 1389 elsif Chars (Selector_Name (Actual)) = Chars (F) then 1390 Set_Entity (Selector_Name (Actual), A_F); 1391 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1392 Generate_Reference (A_F, Selector_Name (Actual)); 1393 1394 Found_Assoc := Actual; 1395 Act := Explicit_Generic_Actual_Parameter (Actual); 1396 Num_Matched := Num_Matched + 1; 1397 exit; 1398 end if; 1399 1400 Prev := Actual; 1401 Next (Actual); 1402 end loop; 1403 1404 -- Reset for subsequent searches. In most cases the named 1405 -- associations are in order. If they are not, we reorder them 1406 -- to avoid scanning twice the same actual. This is not just a 1407 -- question of efficiency: there may be multiple defaults with 1408 -- boxes that have the same name. In a nested instantiation we 1409 -- insert actuals for those defaults, and cannot rely on their 1410 -- names to disambiguate them. 1411 1412 if Actual = First_Named then 1413 Next (First_Named); 1414 1415 elsif Present (Actual) then 1416 Insert_Before (First_Named, Remove_Next (Prev)); 1417 end if; 1418 1419 Actual := First_Named; 1420 end if; 1421 1422 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1423 Set_Used_As_Generic_Actual (Entity (Act)); 1424 end if; 1425 1426 return Act; 1427 end Matching_Actual; 1428 1429 ------------------------------ 1430 -- Partial_Parameterization -- 1431 ------------------------------ 1432 1433 function Partial_Parameterization return Boolean is 1434 begin 1435 return Others_Present 1436 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1437 end Partial_Parameterization; 1438 1439 --------------------- 1440 -- Process_Default -- 1441 --------------------- 1442 1443 procedure Process_Default (F : Entity_Id) is 1444 Loc : constant Source_Ptr := Sloc (I_Node); 1445 F_Id : constant Entity_Id := Defining_Entity (F); 1446 Decl : Node_Id; 1447 Default : Node_Id; 1448 Id : Entity_Id; 1449 1450 begin 1451 -- Append copy of formal declaration to associations, and create new 1452 -- defining identifier for it. 1453 1454 Decl := New_Copy_Tree (F); 1455 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1456 1457 if Nkind (F) in N_Formal_Subprogram_Declaration then 1458 Set_Defining_Unit_Name (Specification (Decl), Id); 1459 1460 else 1461 Set_Defining_Identifier (Decl, Id); 1462 end if; 1463 1464 Append (Decl, Assoc_List); 1465 1466 if No (Found_Assoc) then 1467 Default := 1468 Make_Generic_Association (Loc, 1469 Selector_Name => 1470 New_Occurrence_Of (Id, Loc), 1471 Explicit_Generic_Actual_Parameter => Empty); 1472 Set_Box_Present (Default); 1473 Append (Default, Default_Formals); 1474 end if; 1475 end Process_Default; 1476 1477 --------------------------------- 1478 -- Renames_Standard_Subprogram -- 1479 --------------------------------- 1480 1481 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1482 Id : Entity_Id; 1483 1484 begin 1485 Id := Alias (Subp); 1486 while Present (Id) loop 1487 if Scope (Id) = Standard_Standard then 1488 return True; 1489 end if; 1490 1491 Id := Alias (Id); 1492 end loop; 1493 1494 return False; 1495 end Renames_Standard_Subprogram; 1496 1497 ------------------------- 1498 -- Set_Analyzed_Formal -- 1499 ------------------------- 1500 1501 procedure Set_Analyzed_Formal is 1502 Kind : Node_Kind; 1503 1504 begin 1505 while Present (Analyzed_Formal) loop 1506 Kind := Nkind (Analyzed_Formal); 1507 1508 case Nkind (Formal) is 1509 when N_Formal_Subprogram_Declaration => 1510 exit when Kind in N_Formal_Subprogram_Declaration 1511 and then 1512 Chars 1513 (Defining_Unit_Name (Specification (Formal))) = 1514 Chars 1515 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1516 1517 when N_Formal_Package_Declaration => 1518 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1519 N_Generic_Package_Declaration, 1520 N_Package_Declaration); 1521 1522 when N_Use_Package_Clause 1523 | N_Use_Type_Clause 1524 => 1525 exit; 1526 1527 when others => 1528 1529 -- Skip freeze nodes, and nodes inserted to replace 1530 -- unrecognized pragmas. 1531 1532 exit when 1533 Kind not in N_Formal_Subprogram_Declaration 1534 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1535 N_Freeze_Entity, 1536 N_Null_Statement, 1537 N_Itype_Reference) 1538 and then Chars (Defining_Identifier (Formal)) = 1539 Chars (Defining_Identifier (Analyzed_Formal)); 1540 end case; 1541 1542 Next (Analyzed_Formal); 1543 end loop; 1544 end Set_Analyzed_Formal; 1545 1546 -- Start of processing for Analyze_Associations 1547 1548 begin 1549 Actuals := Generic_Associations (I_Node); 1550 1551 if Present (Actuals) then 1552 1553 -- Check for an Others choice, indicating a partial parameterization 1554 -- for a formal package. 1555 1556 Actual := First (Actuals); 1557 while Present (Actual) loop 1558 if Nkind (Actual) = N_Others_Choice then 1559 Others_Present := True; 1560 Others_Choice := Actual; 1561 1562 if Present (Next (Actual)) then 1563 Error_Msg_N ("others must be last association", Actual); 1564 end if; 1565 1566 -- This subprogram is used both for formal packages and for 1567 -- instantiations. For the latter, associations must all be 1568 -- explicit. 1569 1570 if Nkind (I_Node) /= N_Formal_Package_Declaration 1571 and then Comes_From_Source (I_Node) 1572 then 1573 Error_Msg_N 1574 ("others association not allowed in an instance", 1575 Actual); 1576 end if; 1577 1578 -- In any case, nothing to do after the others association 1579 1580 exit; 1581 1582 elsif Box_Present (Actual) 1583 and then Comes_From_Source (I_Node) 1584 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1585 then 1586 Error_Msg_N 1587 ("box association not allowed in an instance", Actual); 1588 end if; 1589 1590 Next (Actual); 1591 end loop; 1592 1593 -- If named associations are present, save first named association 1594 -- (it may of course be Empty) to facilitate subsequent name search. 1595 1596 First_Named := First (Actuals); 1597 while Present (First_Named) 1598 and then Nkind (First_Named) /= N_Others_Choice 1599 and then No (Selector_Name (First_Named)) 1600 loop 1601 Num_Actuals := Num_Actuals + 1; 1602 Next (First_Named); 1603 end loop; 1604 end if; 1605 1606 Named := First_Named; 1607 while Present (Named) loop 1608 if Nkind (Named) /= N_Others_Choice 1609 and then No (Selector_Name (Named)) 1610 then 1611 Error_Msg_N ("invalid positional actual after named one", Named); 1612 Abandon_Instantiation (Named); 1613 end if; 1614 1615 -- A named association may lack an actual parameter, if it was 1616 -- introduced for a default subprogram that turns out to be local 1617 -- to the outer instantiation. If it has a box association it must 1618 -- correspond to some formal in the generic. 1619 1620 if Nkind (Named) /= N_Others_Choice 1621 and then (Present (Explicit_Generic_Actual_Parameter (Named)) 1622 or else Box_Present (Named)) 1623 then 1624 Num_Actuals := Num_Actuals + 1; 1625 end if; 1626 1627 Next (Named); 1628 end loop; 1629 1630 if Present (Formals) then 1631 Formal := First_Non_Pragma (Formals); 1632 Analyzed_Formal := First_Non_Pragma (F_Copy); 1633 1634 if Present (Actuals) then 1635 Actual := First (Actuals); 1636 1637 -- All formals should have default values 1638 1639 else 1640 Actual := Empty; 1641 end if; 1642 1643 while Present (Formal) loop 1644 Set_Analyzed_Formal; 1645 Saved_Formal := Next_Non_Pragma (Formal); 1646 1647 case Nkind (Formal) is 1648 when N_Formal_Object_Declaration => 1649 Match := 1650 Matching_Actual 1651 (Defining_Identifier (Formal), 1652 Defining_Identifier (Analyzed_Formal)); 1653 1654 if No (Match) and then Partial_Parameterization then 1655 Process_Default (Formal); 1656 1657 else 1658 Append_List 1659 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1660 Assoc_List); 1661 1662 -- For a defaulted in_parameter, create an entry in the 1663 -- the list of defaulted actuals, for GNATProve use. Do 1664 -- not included these defaults for an instance nested 1665 -- within a generic, because the defaults are also used 1666 -- in the analysis of the enclosing generic, and only 1667 -- defaulted subprograms are relevant there. 1668 1669 if No (Match) and then not Inside_A_Generic then 1670 Append_To (Default_Actuals, 1671 Make_Generic_Association (Sloc (I_Node), 1672 Selector_Name => 1673 New_Occurrence_Of 1674 (Defining_Identifier (Formal), Sloc (I_Node)), 1675 Explicit_Generic_Actual_Parameter => 1676 New_Copy_Tree (Default_Expression (Formal)))); 1677 end if; 1678 end if; 1679 1680 -- If the object is a call to an expression function, this 1681 -- is a freezing point for it. 1682 1683 if Is_Entity_Name (Match) 1684 and then Present (Entity (Match)) 1685 and then Nkind 1686 (Original_Node (Unit_Declaration_Node (Entity (Match)))) 1687 = N_Expression_Function 1688 then 1689 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1690 end if; 1691 1692 when N_Formal_Type_Declaration => 1693 Match := 1694 Matching_Actual 1695 (Defining_Identifier (Formal), 1696 Defining_Identifier (Analyzed_Formal)); 1697 1698 if No (Match) then 1699 if Partial_Parameterization then 1700 Process_Default (Formal); 1701 1702 else 1703 Error_Msg_Sloc := Sloc (Gen_Unit); 1704 Error_Msg_NE 1705 ("missing actual&", 1706 Instantiation_Node, Defining_Identifier (Formal)); 1707 Error_Msg_NE 1708 ("\in instantiation of & declared#", 1709 Instantiation_Node, Gen_Unit); 1710 Abandon_Instantiation (Instantiation_Node); 1711 end if; 1712 1713 else 1714 Analyze (Match); 1715 Append_List 1716 (Instantiate_Type 1717 (Formal, Match, Analyzed_Formal, Assoc_List), 1718 Assoc_List); 1719 1720 -- Warn when an actual is a fixed-point with user- 1721 -- defined promitives. The warning is superfluous 1722 -- if the fornal is private, because there can be 1723 -- no arithmetic operations in the generic so there 1724 -- no danger of confusion. 1725 1726 if Is_Fixed_Point_Type (Entity (Match)) 1727 and then not Is_Private_Type 1728 (Defining_Identifier (Analyzed_Formal)) 1729 then 1730 Check_Fixed_Point_Actual (Match); 1731 end if; 1732 1733 -- An instantiation is a freeze point for the actuals, 1734 -- unless this is a rewritten formal package, or the 1735 -- formal is an Ada 2012 formal incomplete type. 1736 1737 if Nkind (I_Node) = N_Formal_Package_Declaration 1738 or else 1739 (Ada_Version >= Ada_2012 1740 and then 1741 Ekind (Defining_Identifier (Analyzed_Formal)) = 1742 E_Incomplete_Type) 1743 then 1744 null; 1745 1746 else 1747 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1748 end if; 1749 end if; 1750 1751 -- A remote access-to-class-wide type is not a legal actual 1752 -- for a generic formal of an access type (E.2.2(17/2)). 1753 -- In GNAT an exception to this rule is introduced when 1754 -- the formal is marked as remote using implementation 1755 -- defined aspect/pragma Remote_Access_Type. In that case 1756 -- the actual must be remote as well. 1757 1758 -- If the current instantiation is the construction of a 1759 -- local copy for a formal package the actuals may be 1760 -- defaulted, and there is no matching actual to check. 1761 1762 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1763 and then 1764 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1765 N_Access_To_Object_Definition 1766 and then Present (Match) 1767 then 1768 declare 1769 Formal_Ent : constant Entity_Id := 1770 Defining_Identifier (Analyzed_Formal); 1771 begin 1772 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1773 = Is_Remote_Types (Formal_Ent) 1774 then 1775 -- Remoteness of formal and actual match 1776 1777 null; 1778 1779 elsif Is_Remote_Types (Formal_Ent) then 1780 1781 -- Remote formal, non-remote actual 1782 1783 Error_Msg_NE 1784 ("actual for& must be remote", Match, Formal_Ent); 1785 1786 else 1787 -- Non-remote formal, remote actual 1788 1789 Error_Msg_NE 1790 ("actual for& may not be remote", 1791 Match, Formal_Ent); 1792 end if; 1793 end; 1794 end if; 1795 1796 when N_Formal_Subprogram_Declaration => 1797 Match := 1798 Matching_Actual 1799 (Defining_Unit_Name (Specification (Formal)), 1800 Defining_Unit_Name (Specification (Analyzed_Formal))); 1801 1802 -- If the formal subprogram has the same name as another 1803 -- formal subprogram of the generic, then a named 1804 -- association is illegal (12.3(9)). Exclude named 1805 -- associations that are generated for a nested instance. 1806 1807 if Present (Match) 1808 and then Is_Named_Assoc 1809 and then Comes_From_Source (Found_Assoc) 1810 then 1811 Check_Overloaded_Formal_Subprogram (Formal); 1812 end if; 1813 1814 -- If there is no corresponding actual, this may be case 1815 -- of partial parameterization, or else the formal has a 1816 -- default or a box. 1817 1818 if No (Match) and then Partial_Parameterization then 1819 Process_Default (Formal); 1820 1821 if Nkind (I_Node) = N_Formal_Package_Declaration then 1822 Check_Overloaded_Formal_Subprogram (Formal); 1823 end if; 1824 1825 else 1826 Append_To (Assoc_List, 1827 Instantiate_Formal_Subprogram 1828 (Formal, Match, Analyzed_Formal)); 1829 1830 -- An instantiation is a freeze point for the actuals, 1831 -- unless this is a rewritten formal package. 1832 1833 if Nkind (I_Node) /= N_Formal_Package_Declaration 1834 and then Nkind (Match) = N_Identifier 1835 and then Is_Subprogram (Entity (Match)) 1836 1837 -- The actual subprogram may rename a routine defined 1838 -- in Standard. Avoid freezing such renamings because 1839 -- subprograms coming from Standard cannot be frozen. 1840 1841 and then 1842 not Renames_Standard_Subprogram (Entity (Match)) 1843 1844 -- If the actual subprogram comes from a different 1845 -- unit, it is already frozen, either by a body in 1846 -- that unit or by the end of the declarative part 1847 -- of the unit. This check avoids the freezing of 1848 -- subprograms defined in Standard which are used 1849 -- as generic actuals. 1850 1851 and then In_Same_Code_Unit (Entity (Match), I_Node) 1852 and then Has_Fully_Defined_Profile (Entity (Match)) 1853 then 1854 -- Mark the subprogram as having a delayed freeze 1855 -- since this may be an out-of-order action. 1856 1857 Set_Has_Delayed_Freeze (Entity (Match)); 1858 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1859 end if; 1860 end if; 1861 1862 -- If this is a nested generic, preserve default for later 1863 -- instantiations. We do this as well for GNATProve use, 1864 -- so that the list of generic associations is complete. 1865 1866 if No (Match) and then Box_Present (Formal) then 1867 declare 1868 Subp : constant Entity_Id := 1869 Defining_Unit_Name 1870 (Specification (Last (Assoc_List))); 1871 1872 begin 1873 Append_To (Default_Actuals, 1874 Make_Generic_Association (Sloc (I_Node), 1875 Selector_Name => 1876 New_Occurrence_Of (Subp, Sloc (I_Node)), 1877 Explicit_Generic_Actual_Parameter => 1878 New_Occurrence_Of (Subp, Sloc (I_Node)))); 1879 end; 1880 end if; 1881 1882 when N_Formal_Package_Declaration => 1883 Match := 1884 Matching_Actual 1885 (Defining_Identifier (Formal), 1886 Defining_Identifier (Original_Node (Analyzed_Formal))); 1887 1888 if No (Match) then 1889 if Partial_Parameterization then 1890 Process_Default (Formal); 1891 1892 else 1893 Error_Msg_Sloc := Sloc (Gen_Unit); 1894 Error_Msg_NE 1895 ("missing actual&", 1896 Instantiation_Node, Defining_Identifier (Formal)); 1897 Error_Msg_NE 1898 ("\in instantiation of & declared#", 1899 Instantiation_Node, Gen_Unit); 1900 1901 Abandon_Instantiation (Instantiation_Node); 1902 end if; 1903 1904 else 1905 Analyze (Match); 1906 Append_List 1907 (Instantiate_Formal_Package 1908 (Formal, Match, Analyzed_Formal), 1909 Assoc_List); 1910 1911 -- Determine whether the actual package needs an explicit 1912 -- freeze node. This is only the case if the actual is 1913 -- declared in the same unit and has a body. Normally 1914 -- packages do not have explicit freeze nodes, and gigi 1915 -- only uses them to elaborate entities in a package 1916 -- body. 1917 1918 Explicit_Freeze_Check : declare 1919 Actual : constant Entity_Id := Entity (Match); 1920 Gen_Par : Entity_Id; 1921 1922 Needs_Freezing : Boolean; 1923 S : Entity_Id; 1924 1925 procedure Check_Generic_Parent; 1926 -- The actual may be an instantiation of a unit 1927 -- declared in a previous instantiation. If that 1928 -- one is also in the current compilation, it must 1929 -- itself be frozen before the actual. The actual 1930 -- may be an instantiation of a generic child unit, 1931 -- in which case the same applies to the instance 1932 -- of the parent which must be frozen before the 1933 -- actual. 1934 -- Should this itself be recursive ??? 1935 1936 -------------------------- 1937 -- Check_Generic_Parent -- 1938 -------------------------- 1939 1940 procedure Check_Generic_Parent is 1941 Inst : constant Node_Id := 1942 Next (Unit_Declaration_Node (Actual)); 1943 Par : Entity_Id; 1944 1945 begin 1946 Par := Empty; 1947 1948 if Nkind (Parent (Actual)) = N_Package_Specification 1949 then 1950 Par := Scope (Generic_Parent (Parent (Actual))); 1951 1952 if Is_Generic_Instance (Par) then 1953 null; 1954 1955 -- If the actual is a child generic unit, check 1956 -- whether the instantiation of the parent is 1957 -- also local and must also be frozen now. We 1958 -- must retrieve the instance node to locate the 1959 -- parent instance if any. 1960 1961 elsif Ekind (Par) = E_Generic_Package 1962 and then Is_Child_Unit (Gen_Par) 1963 and then Ekind (Scope (Gen_Par)) = 1964 E_Generic_Package 1965 then 1966 if Nkind (Inst) = N_Package_Instantiation 1967 and then Nkind (Name (Inst)) = 1968 N_Expanded_Name 1969 then 1970 -- Retrieve entity of parent instance 1971 1972 Par := Entity (Prefix (Name (Inst))); 1973 end if; 1974 1975 else 1976 Par := Empty; 1977 end if; 1978 end if; 1979 1980 if Present (Par) 1981 and then Is_Generic_Instance (Par) 1982 and then Scope (Par) = Current_Scope 1983 and then 1984 (No (Freeze_Node (Par)) 1985 or else 1986 not Is_List_Member (Freeze_Node (Par))) 1987 then 1988 Set_Has_Delayed_Freeze (Par); 1989 Append_Elmt (Par, Actuals_To_Freeze); 1990 end if; 1991 end Check_Generic_Parent; 1992 1993 -- Start of processing for Explicit_Freeze_Check 1994 1995 begin 1996 if Present (Renamed_Entity (Actual)) then 1997 Gen_Par := 1998 Generic_Parent (Specification 1999 (Unit_Declaration_Node 2000 (Renamed_Entity (Actual)))); 2001 else 2002 Gen_Par := 2003 Generic_Parent (Specification 2004 (Unit_Declaration_Node (Actual))); 2005 end if; 2006 2007 if not Expander_Active 2008 or else not Has_Completion (Actual) 2009 or else not In_Same_Source_Unit (I_Node, Actual) 2010 or else Is_Frozen (Actual) 2011 or else 2012 (Present (Renamed_Entity (Actual)) 2013 and then 2014 not In_Same_Source_Unit 2015 (I_Node, (Renamed_Entity (Actual)))) 2016 then 2017 null; 2018 2019 else 2020 -- Finally we want to exclude such freeze nodes 2021 -- from statement sequences, which freeze 2022 -- everything before them. 2023 -- Is this strictly necessary ??? 2024 2025 Needs_Freezing := True; 2026 2027 S := Current_Scope; 2028 while Present (S) loop 2029 if Ekind_In (S, E_Block, 2030 E_Function, 2031 E_Loop, 2032 E_Procedure) 2033 then 2034 Needs_Freezing := False; 2035 exit; 2036 end if; 2037 2038 S := Scope (S); 2039 end loop; 2040 2041 if Needs_Freezing then 2042 Check_Generic_Parent; 2043 2044 -- If the actual is a renaming of a proper 2045 -- instance of the formal package, indicate 2046 -- that it is the instance that must be frozen. 2047 2048 if Nkind (Parent (Actual)) = 2049 N_Package_Renaming_Declaration 2050 then 2051 Set_Has_Delayed_Freeze 2052 (Renamed_Entity (Actual)); 2053 Append_Elmt 2054 (Renamed_Entity (Actual), 2055 Actuals_To_Freeze); 2056 else 2057 Set_Has_Delayed_Freeze (Actual); 2058 Append_Elmt (Actual, Actuals_To_Freeze); 2059 end if; 2060 end if; 2061 end if; 2062 end Explicit_Freeze_Check; 2063 end if; 2064 2065 -- For use type and use package appearing in the generic part, 2066 -- we have already copied them, so we can just move them where 2067 -- they belong (we mustn't recopy them since this would mess up 2068 -- the Sloc values). 2069 2070 when N_Use_Package_Clause 2071 | N_Use_Type_Clause 2072 => 2073 if Nkind (Original_Node (I_Node)) = 2074 N_Formal_Package_Declaration 2075 then 2076 Append (New_Copy_Tree (Formal), Assoc_List); 2077 else 2078 Remove (Formal); 2079 Append (Formal, Assoc_List); 2080 end if; 2081 2082 when others => 2083 raise Program_Error; 2084 end case; 2085 2086 Formal := Saved_Formal; 2087 Next_Non_Pragma (Analyzed_Formal); 2088 end loop; 2089 2090 if Num_Actuals > Num_Matched then 2091 Error_Msg_Sloc := Sloc (Gen_Unit); 2092 2093 if Present (Selector_Name (Actual)) then 2094 Error_Msg_NE 2095 ("unmatched actual &", Actual, Selector_Name (Actual)); 2096 Error_Msg_NE 2097 ("\in instantiation of & declared#", Actual, Gen_Unit); 2098 else 2099 Error_Msg_NE 2100 ("unmatched actual in instantiation of & declared#", 2101 Actual, Gen_Unit); 2102 end if; 2103 end if; 2104 2105 elsif Present (Actuals) then 2106 Error_Msg_N 2107 ("too many actuals in generic instantiation", Instantiation_Node); 2108 end if; 2109 2110 -- An instantiation freezes all generic actuals. The only exceptions 2111 -- to this are incomplete types and subprograms which are not fully 2112 -- defined at the point of instantiation. 2113 2114 declare 2115 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 2116 begin 2117 while Present (Elmt) loop 2118 Freeze_Before (I_Node, Node (Elmt)); 2119 Next_Elmt (Elmt); 2120 end loop; 2121 end; 2122 2123 -- If there are default subprograms, normalize the tree by adding 2124 -- explicit associations for them. This is required if the instance 2125 -- appears within a generic. 2126 2127 if not Is_Empty_List (Default_Actuals) then 2128 declare 2129 Default : Node_Id; 2130 2131 begin 2132 Default := First (Default_Actuals); 2133 while Present (Default) loop 2134 Mark_Rewrite_Insertion (Default); 2135 Next (Default); 2136 end loop; 2137 2138 if No (Actuals) then 2139 Set_Generic_Associations (I_Node, Default_Actuals); 2140 else 2141 Append_List_To (Actuals, Default_Actuals); 2142 end if; 2143 end; 2144 end if; 2145 2146 -- If this is a formal package, normalize the parameter list by adding 2147 -- explicit box associations for the formals that are covered by an 2148 -- Others_Choice. 2149 2150 if not Is_Empty_List (Default_Formals) then 2151 Append_List (Default_Formals, Formals); 2152 end if; 2153 2154 return Assoc_List; 2155 end Analyze_Associations; 2156 2157 ------------------------------- 2158 -- Analyze_Formal_Array_Type -- 2159 ------------------------------- 2160 2161 procedure Analyze_Formal_Array_Type 2162 (T : in out Entity_Id; 2163 Def : Node_Id) 2164 is 2165 DSS : Node_Id; 2166 2167 begin 2168 -- Treated like a non-generic array declaration, with additional 2169 -- semantic checks. 2170 2171 Enter_Name (T); 2172 2173 if Nkind (Def) = N_Constrained_Array_Definition then 2174 DSS := First (Discrete_Subtype_Definitions (Def)); 2175 while Present (DSS) loop 2176 if Nkind_In (DSS, N_Subtype_Indication, 2177 N_Range, 2178 N_Attribute_Reference) 2179 then 2180 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 2181 end if; 2182 2183 Next (DSS); 2184 end loop; 2185 end if; 2186 2187 Array_Type_Declaration (T, Def); 2188 Set_Is_Generic_Type (Base_Type (T)); 2189 2190 if Ekind (Component_Type (T)) = E_Incomplete_Type 2191 and then No (Full_View (Component_Type (T))) 2192 then 2193 Error_Msg_N ("premature usage of incomplete type", Def); 2194 2195 -- Check that range constraint is not allowed on the component type 2196 -- of a generic formal array type (AARM 12.5.3(3)) 2197 2198 elsif Is_Internal (Component_Type (T)) 2199 and then Present (Subtype_Indication (Component_Definition (Def))) 2200 and then Nkind (Original_Node 2201 (Subtype_Indication (Component_Definition (Def)))) = 2202 N_Subtype_Indication 2203 then 2204 Error_Msg_N 2205 ("in a formal, a subtype indication can only be " 2206 & "a subtype mark (RM 12.5.3(3))", 2207 Subtype_Indication (Component_Definition (Def))); 2208 end if; 2209 2210 end Analyze_Formal_Array_Type; 2211 2212 --------------------------------------------- 2213 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 2214 --------------------------------------------- 2215 2216 -- As for other generic types, we create a valid type representation with 2217 -- legal but arbitrary attributes, whose values are never considered 2218 -- static. For all scalar types we introduce an anonymous base type, with 2219 -- the same attributes. We choose the corresponding integer type to be 2220 -- Standard_Integer. 2221 -- Here and in other similar routines, the Sloc of the generated internal 2222 -- type must be the same as the sloc of the defining identifier of the 2223 -- formal type declaration, to provide proper source navigation. 2224 2225 procedure Analyze_Formal_Decimal_Fixed_Point_Type 2226 (T : Entity_Id; 2227 Def : Node_Id) 2228 is 2229 Loc : constant Source_Ptr := Sloc (Def); 2230 2231 Base : constant Entity_Id := 2232 New_Internal_Entity 2233 (E_Decimal_Fixed_Point_Type, 2234 Current_Scope, 2235 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2236 2237 Int_Base : constant Entity_Id := Standard_Integer; 2238 Delta_Val : constant Ureal := Ureal_1; 2239 Digs_Val : constant Uint := Uint_6; 2240 2241 function Make_Dummy_Bound return Node_Id; 2242 -- Return a properly typed universal real literal to use as a bound 2243 2244 ---------------------- 2245 -- Make_Dummy_Bound -- 2246 ---------------------- 2247 2248 function Make_Dummy_Bound return Node_Id is 2249 Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1); 2250 begin 2251 Set_Etype (Bound, Universal_Real); 2252 return Bound; 2253 end Make_Dummy_Bound; 2254 2255 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type 2256 2257 begin 2258 Enter_Name (T); 2259 2260 Set_Etype (Base, Base); 2261 Set_Size_Info (Base, Int_Base); 2262 Set_RM_Size (Base, RM_Size (Int_Base)); 2263 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 2264 Set_Digits_Value (Base, Digs_Val); 2265 Set_Delta_Value (Base, Delta_Val); 2266 Set_Small_Value (Base, Delta_Val); 2267 Set_Scalar_Range (Base, 2268 Make_Range (Loc, 2269 Low_Bound => Make_Dummy_Bound, 2270 High_Bound => Make_Dummy_Bound)); 2271 2272 Set_Is_Generic_Type (Base); 2273 Set_Parent (Base, Parent (Def)); 2274 2275 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 2276 Set_Etype (T, Base); 2277 Set_Size_Info (T, Int_Base); 2278 Set_RM_Size (T, RM_Size (Int_Base)); 2279 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 2280 Set_Digits_Value (T, Digs_Val); 2281 Set_Delta_Value (T, Delta_Val); 2282 Set_Small_Value (T, Delta_Val); 2283 Set_Scalar_Range (T, Scalar_Range (Base)); 2284 Set_Is_Constrained (T); 2285 2286 Check_Restriction (No_Fixed_Point, Def); 2287 end Analyze_Formal_Decimal_Fixed_Point_Type; 2288 2289 ------------------------------------------- 2290 -- Analyze_Formal_Derived_Interface_Type -- 2291 ------------------------------------------- 2292 2293 procedure Analyze_Formal_Derived_Interface_Type 2294 (N : Node_Id; 2295 T : Entity_Id; 2296 Def : Node_Id) 2297 is 2298 Loc : constant Source_Ptr := Sloc (Def); 2299 2300 begin 2301 -- Rewrite as a type declaration of a derived type. This ensures that 2302 -- the interface list and primitive operations are properly captured. 2303 2304 Rewrite (N, 2305 Make_Full_Type_Declaration (Loc, 2306 Defining_Identifier => T, 2307 Type_Definition => Def)); 2308 Analyze (N); 2309 Set_Is_Generic_Type (T); 2310 end Analyze_Formal_Derived_Interface_Type; 2311 2312 --------------------------------- 2313 -- Analyze_Formal_Derived_Type -- 2314 --------------------------------- 2315 2316 procedure Analyze_Formal_Derived_Type 2317 (N : Node_Id; 2318 T : Entity_Id; 2319 Def : Node_Id) 2320 is 2321 Loc : constant Source_Ptr := Sloc (Def); 2322 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 2323 New_N : Node_Id; 2324 2325 begin 2326 Set_Is_Generic_Type (T); 2327 2328 if Private_Present (Def) then 2329 New_N := 2330 Make_Private_Extension_Declaration (Loc, 2331 Defining_Identifier => T, 2332 Discriminant_Specifications => Discriminant_Specifications (N), 2333 Unknown_Discriminants_Present => Unk_Disc, 2334 Subtype_Indication => Subtype_Mark (Def), 2335 Interface_List => Interface_List (Def)); 2336 2337 Set_Abstract_Present (New_N, Abstract_Present (Def)); 2338 Set_Limited_Present (New_N, Limited_Present (Def)); 2339 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 2340 2341 else 2342 New_N := 2343 Make_Full_Type_Declaration (Loc, 2344 Defining_Identifier => T, 2345 Discriminant_Specifications => 2346 Discriminant_Specifications (Parent (T)), 2347 Type_Definition => 2348 Make_Derived_Type_Definition (Loc, 2349 Subtype_Indication => Subtype_Mark (Def))); 2350 2351 Set_Abstract_Present 2352 (Type_Definition (New_N), Abstract_Present (Def)); 2353 Set_Limited_Present 2354 (Type_Definition (New_N), Limited_Present (Def)); 2355 end if; 2356 2357 Rewrite (N, New_N); 2358 Analyze (N); 2359 2360 if Unk_Disc then 2361 if not Is_Composite_Type (T) then 2362 Error_Msg_N 2363 ("unknown discriminants not allowed for elementary types", N); 2364 else 2365 Set_Has_Unknown_Discriminants (T); 2366 Set_Is_Constrained (T, False); 2367 end if; 2368 end if; 2369 2370 -- If the parent type has a known size, so does the formal, which makes 2371 -- legal representation clauses that involve the formal. 2372 2373 Set_Size_Known_At_Compile_Time 2374 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 2375 end Analyze_Formal_Derived_Type; 2376 2377 ---------------------------------- 2378 -- Analyze_Formal_Discrete_Type -- 2379 ---------------------------------- 2380 2381 -- The operations defined for a discrete types are those of an enumeration 2382 -- type. The size is set to an arbitrary value, for use in analyzing the 2383 -- generic unit. 2384 2385 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 2386 Loc : constant Source_Ptr := Sloc (Def); 2387 Lo : Node_Id; 2388 Hi : Node_Id; 2389 2390 Base : constant Entity_Id := 2391 New_Internal_Entity 2392 (E_Floating_Point_Type, Current_Scope, 2393 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2394 2395 begin 2396 Enter_Name (T); 2397 Set_Ekind (T, E_Enumeration_Subtype); 2398 Set_Etype (T, Base); 2399 Init_Size (T, 8); 2400 Init_Alignment (T); 2401 Set_Is_Generic_Type (T); 2402 Set_Is_Constrained (T); 2403 2404 -- For semantic analysis, the bounds of the type must be set to some 2405 -- non-static value. The simplest is to create attribute nodes for those 2406 -- bounds, that refer to the type itself. These bounds are never 2407 -- analyzed but serve as place-holders. 2408 2409 Lo := 2410 Make_Attribute_Reference (Loc, 2411 Attribute_Name => Name_First, 2412 Prefix => New_Occurrence_Of (T, Loc)); 2413 Set_Etype (Lo, T); 2414 2415 Hi := 2416 Make_Attribute_Reference (Loc, 2417 Attribute_Name => Name_Last, 2418 Prefix => New_Occurrence_Of (T, Loc)); 2419 Set_Etype (Hi, T); 2420 2421 Set_Scalar_Range (T, 2422 Make_Range (Loc, 2423 Low_Bound => Lo, 2424 High_Bound => Hi)); 2425 2426 Set_Ekind (Base, E_Enumeration_Type); 2427 Set_Etype (Base, Base); 2428 Init_Size (Base, 8); 2429 Init_Alignment (Base); 2430 Set_Is_Generic_Type (Base); 2431 Set_Scalar_Range (Base, Scalar_Range (T)); 2432 Set_Parent (Base, Parent (Def)); 2433 end Analyze_Formal_Discrete_Type; 2434 2435 ---------------------------------- 2436 -- Analyze_Formal_Floating_Type -- 2437 --------------------------------- 2438 2439 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 2440 Base : constant Entity_Id := 2441 New_Internal_Entity 2442 (E_Floating_Point_Type, Current_Scope, 2443 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2444 2445 begin 2446 -- The various semantic attributes are taken from the predefined type 2447 -- Float, just so that all of them are initialized. Their values are 2448 -- never used because no constant folding or expansion takes place in 2449 -- the generic itself. 2450 2451 Enter_Name (T); 2452 Set_Ekind (T, E_Floating_Point_Subtype); 2453 Set_Etype (T, Base); 2454 Set_Size_Info (T, (Standard_Float)); 2455 Set_RM_Size (T, RM_Size (Standard_Float)); 2456 Set_Digits_Value (T, Digits_Value (Standard_Float)); 2457 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 2458 Set_Is_Constrained (T); 2459 2460 Set_Is_Generic_Type (Base); 2461 Set_Etype (Base, Base); 2462 Set_Size_Info (Base, (Standard_Float)); 2463 Set_RM_Size (Base, RM_Size (Standard_Float)); 2464 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 2465 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 2466 Set_Parent (Base, Parent (Def)); 2467 2468 Check_Restriction (No_Floating_Point, Def); 2469 end Analyze_Formal_Floating_Type; 2470 2471 ----------------------------------- 2472 -- Analyze_Formal_Interface_Type;-- 2473 ----------------------------------- 2474 2475 procedure Analyze_Formal_Interface_Type 2476 (N : Node_Id; 2477 T : Entity_Id; 2478 Def : Node_Id) 2479 is 2480 Loc : constant Source_Ptr := Sloc (N); 2481 New_N : Node_Id; 2482 2483 begin 2484 New_N := 2485 Make_Full_Type_Declaration (Loc, 2486 Defining_Identifier => T, 2487 Type_Definition => Def); 2488 2489 Rewrite (N, New_N); 2490 Analyze (N); 2491 Set_Is_Generic_Type (T); 2492 end Analyze_Formal_Interface_Type; 2493 2494 --------------------------------- 2495 -- Analyze_Formal_Modular_Type -- 2496 --------------------------------- 2497 2498 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2499 begin 2500 -- Apart from their entity kind, generic modular types are treated like 2501 -- signed integer types, and have the same attributes. 2502 2503 Analyze_Formal_Signed_Integer_Type (T, Def); 2504 Set_Ekind (T, E_Modular_Integer_Subtype); 2505 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2506 2507 end Analyze_Formal_Modular_Type; 2508 2509 --------------------------------------- 2510 -- Analyze_Formal_Object_Declaration -- 2511 --------------------------------------- 2512 2513 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2514 E : constant Node_Id := Default_Expression (N); 2515 Id : constant Node_Id := Defining_Identifier (N); 2516 K : Entity_Kind; 2517 T : Node_Id; 2518 2519 begin 2520 Enter_Name (Id); 2521 2522 -- Determine the mode of the formal object 2523 2524 if Out_Present (N) then 2525 K := E_Generic_In_Out_Parameter; 2526 2527 if not In_Present (N) then 2528 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2529 end if; 2530 2531 else 2532 K := E_Generic_In_Parameter; 2533 end if; 2534 2535 if Present (Subtype_Mark (N)) then 2536 Find_Type (Subtype_Mark (N)); 2537 T := Entity (Subtype_Mark (N)); 2538 2539 -- Verify that there is no redundant null exclusion 2540 2541 if Null_Exclusion_Present (N) then 2542 if not Is_Access_Type (T) then 2543 Error_Msg_N 2544 ("null exclusion can only apply to an access type", N); 2545 2546 elsif Can_Never_Be_Null (T) then 2547 Error_Msg_NE 2548 ("`NOT NULL` not allowed (& already excludes null)", N, T); 2549 end if; 2550 end if; 2551 2552 -- Ada 2005 (AI-423): Formal object with an access definition 2553 2554 else 2555 Check_Access_Definition (N); 2556 T := Access_Definition 2557 (Related_Nod => N, 2558 N => Access_Definition (N)); 2559 end if; 2560 2561 if Ekind (T) = E_Incomplete_Type then 2562 declare 2563 Error_Node : Node_Id; 2564 2565 begin 2566 if Present (Subtype_Mark (N)) then 2567 Error_Node := Subtype_Mark (N); 2568 else 2569 Check_Access_Definition (N); 2570 Error_Node := Access_Definition (N); 2571 end if; 2572 2573 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2574 end; 2575 end if; 2576 2577 if K = E_Generic_In_Parameter then 2578 2579 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2580 2581 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2582 Error_Msg_N 2583 ("generic formal of mode IN must not be of limited type", N); 2584 Explain_Limited_Type (T, N); 2585 end if; 2586 2587 if Is_Abstract_Type (T) then 2588 Error_Msg_N 2589 ("generic formal of mode IN must not be of abstract type", N); 2590 end if; 2591 2592 if Present (E) then 2593 Preanalyze_Spec_Expression (E, T); 2594 2595 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2596 Error_Msg_N 2597 ("initialization not allowed for limited types", E); 2598 Explain_Limited_Type (T, E); 2599 end if; 2600 end if; 2601 2602 Set_Ekind (Id, K); 2603 Set_Etype (Id, T); 2604 2605 -- Case of generic IN OUT parameter 2606 2607 else 2608 -- If the formal has an unconstrained type, construct its actual 2609 -- subtype, as is done for subprogram formals. In this fashion, all 2610 -- its uses can refer to specific bounds. 2611 2612 Set_Ekind (Id, K); 2613 Set_Etype (Id, T); 2614 2615 if (Is_Array_Type (T) and then not Is_Constrained (T)) 2616 or else (Ekind (T) = E_Record_Type and then Has_Discriminants (T)) 2617 then 2618 declare 2619 Non_Freezing_Ref : constant Node_Id := 2620 New_Occurrence_Of (Id, Sloc (Id)); 2621 Decl : Node_Id; 2622 2623 begin 2624 -- Make sure the actual subtype doesn't generate bogus freezing 2625 2626 Set_Must_Not_Freeze (Non_Freezing_Ref); 2627 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2628 Insert_Before_And_Analyze (N, Decl); 2629 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2630 end; 2631 else 2632 Set_Actual_Subtype (Id, T); 2633 end if; 2634 2635 if Present (E) then 2636 Error_Msg_N 2637 ("initialization not allowed for `IN OUT` formals", N); 2638 end if; 2639 end if; 2640 2641 if Has_Aspects (N) then 2642 Analyze_Aspect_Specifications (N, Id); 2643 end if; 2644 end Analyze_Formal_Object_Declaration; 2645 2646 ---------------------------------------------- 2647 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2648 ---------------------------------------------- 2649 2650 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2651 (T : Entity_Id; 2652 Def : Node_Id) 2653 is 2654 Loc : constant Source_Ptr := Sloc (Def); 2655 Base : constant Entity_Id := 2656 New_Internal_Entity 2657 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2658 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2659 2660 begin 2661 -- The semantic attributes are set for completeness only, their values 2662 -- will never be used, since all properties of the type are non-static. 2663 2664 Enter_Name (T); 2665 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2666 Set_Etype (T, Base); 2667 Set_Size_Info (T, Standard_Integer); 2668 Set_RM_Size (T, RM_Size (Standard_Integer)); 2669 Set_Small_Value (T, Ureal_1); 2670 Set_Delta_Value (T, Ureal_1); 2671 Set_Scalar_Range (T, 2672 Make_Range (Loc, 2673 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2674 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2675 Set_Is_Constrained (T); 2676 2677 Set_Is_Generic_Type (Base); 2678 Set_Etype (Base, Base); 2679 Set_Size_Info (Base, Standard_Integer); 2680 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2681 Set_Small_Value (Base, Ureal_1); 2682 Set_Delta_Value (Base, Ureal_1); 2683 Set_Scalar_Range (Base, Scalar_Range (T)); 2684 Set_Parent (Base, Parent (Def)); 2685 2686 Check_Restriction (No_Fixed_Point, Def); 2687 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2688 2689 ---------------------------------------- 2690 -- Analyze_Formal_Package_Declaration -- 2691 ---------------------------------------- 2692 2693 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2694 Gen_Id : constant Node_Id := Name (N); 2695 Loc : constant Source_Ptr := Sloc (N); 2696 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2697 Formal : Entity_Id; 2698 Gen_Decl : Node_Id; 2699 Gen_Unit : Entity_Id; 2700 Renaming : Node_Id; 2701 2702 Vis_Prims_List : Elist_Id := No_Elist; 2703 -- List of primitives made temporarily visible in the instantiation 2704 -- to match the visibility of the formal type. 2705 2706 function Build_Local_Package return Node_Id; 2707 -- The formal package is rewritten so that its parameters are replaced 2708 -- with corresponding declarations. For parameters with bona fide 2709 -- associations these declarations are created by Analyze_Associations 2710 -- as for a regular instantiation. For boxed parameters, we preserve 2711 -- the formal declarations and analyze them, in order to introduce 2712 -- entities of the right kind in the environment of the formal. 2713 2714 ------------------------- 2715 -- Build_Local_Package -- 2716 ------------------------- 2717 2718 function Build_Local_Package return Node_Id is 2719 Decls : List_Id; 2720 Pack_Decl : Node_Id; 2721 2722 begin 2723 -- Within the formal, the name of the generic package is a renaming 2724 -- of the formal (as for a regular instantiation). 2725 2726 Pack_Decl := 2727 Make_Package_Declaration (Loc, 2728 Specification => 2729 Copy_Generic_Node 2730 (Specification (Original_Node (Gen_Decl)), 2731 Empty, Instantiating => True)); 2732 2733 Renaming := 2734 Make_Package_Renaming_Declaration (Loc, 2735 Defining_Unit_Name => 2736 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2737 Name => New_Occurrence_Of (Formal, Loc)); 2738 2739 if Nkind (Gen_Id) = N_Identifier 2740 and then Chars (Gen_Id) = Chars (Pack_Id) 2741 then 2742 Error_Msg_NE 2743 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2744 end if; 2745 2746 -- If the formal is declared with a box, or with an others choice, 2747 -- create corresponding declarations for all entities in the formal 2748 -- part, so that names with the proper types are available in the 2749 -- specification of the formal package. 2750 2751 -- On the other hand, if there are no associations, then all the 2752 -- formals must have defaults, and this will be checked by the 2753 -- call to Analyze_Associations. 2754 2755 if Box_Present (N) 2756 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2757 then 2758 declare 2759 Formal_Decl : Node_Id; 2760 2761 begin 2762 -- TBA : for a formal package, need to recurse ??? 2763 2764 Decls := New_List; 2765 Formal_Decl := 2766 First 2767 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2768 while Present (Formal_Decl) loop 2769 Append_To 2770 (Decls, 2771 Copy_Generic_Node 2772 (Formal_Decl, Empty, Instantiating => True)); 2773 Next (Formal_Decl); 2774 end loop; 2775 end; 2776 2777 -- If generic associations are present, use Analyze_Associations to 2778 -- create the proper renaming declarations. 2779 2780 else 2781 declare 2782 Act_Tree : constant Node_Id := 2783 Copy_Generic_Node 2784 (Original_Node (Gen_Decl), Empty, 2785 Instantiating => True); 2786 2787 begin 2788 Generic_Renamings.Set_Last (0); 2789 Generic_Renamings_HTable.Reset; 2790 Instantiation_Node := N; 2791 2792 Decls := 2793 Analyze_Associations 2794 (I_Node => Original_Node (N), 2795 Formals => Generic_Formal_Declarations (Act_Tree), 2796 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2797 2798 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2799 end; 2800 end if; 2801 2802 Append (Renaming, To => Decls); 2803 2804 -- Add generated declarations ahead of local declarations in 2805 -- the package. 2806 2807 if No (Visible_Declarations (Specification (Pack_Decl))) then 2808 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2809 else 2810 Insert_List_Before 2811 (First (Visible_Declarations (Specification (Pack_Decl))), 2812 Decls); 2813 end if; 2814 2815 return Pack_Decl; 2816 end Build_Local_Package; 2817 2818 -- Local variables 2819 2820 Save_ISMP : constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance; 2821 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit 2822 2823 Associations : Boolean := True; 2824 New_N : Node_Id; 2825 Parent_Installed : Boolean := False; 2826 Parent_Instance : Entity_Id; 2827 Renaming_In_Par : Entity_Id; 2828 2829 -- Start of processing for Analyze_Formal_Package_Declaration 2830 2831 begin 2832 Check_Text_IO_Special_Unit (Gen_Id); 2833 2834 Init_Env; 2835 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2836 Gen_Unit := Entity (Gen_Id); 2837 2838 -- Check for a formal package that is a package renaming 2839 2840 if Present (Renamed_Object (Gen_Unit)) then 2841 2842 -- Indicate that unit is used, before replacing it with renamed 2843 -- entity for use below. 2844 2845 if In_Extended_Main_Source_Unit (N) then 2846 Set_Is_Instantiated (Gen_Unit); 2847 Generate_Reference (Gen_Unit, N); 2848 end if; 2849 2850 Gen_Unit := Renamed_Object (Gen_Unit); 2851 end if; 2852 2853 if Ekind (Gen_Unit) /= E_Generic_Package then 2854 Error_Msg_N ("expect generic package name", Gen_Id); 2855 Restore_Env; 2856 goto Leave; 2857 2858 elsif Gen_Unit = Current_Scope then 2859 Error_Msg_N 2860 ("generic package cannot be used as a formal package of itself", 2861 Gen_Id); 2862 Restore_Env; 2863 goto Leave; 2864 2865 elsif In_Open_Scopes (Gen_Unit) then 2866 if Is_Compilation_Unit (Gen_Unit) 2867 and then Is_Child_Unit (Current_Scope) 2868 then 2869 -- Special-case the error when the formal is a parent, and 2870 -- continue analysis to minimize cascaded errors. 2871 2872 Error_Msg_N 2873 ("generic parent cannot be used as formal package of a child " 2874 & "unit", Gen_Id); 2875 2876 else 2877 Error_Msg_N 2878 ("generic package cannot be used as a formal package within " 2879 & "itself", Gen_Id); 2880 Restore_Env; 2881 goto Leave; 2882 end if; 2883 end if; 2884 2885 -- Check that name of formal package does not hide name of generic, 2886 -- or its leading prefix. This check must be done separately because 2887 -- the name of the generic has already been analyzed. 2888 2889 declare 2890 Gen_Name : Entity_Id; 2891 2892 begin 2893 Gen_Name := Gen_Id; 2894 while Nkind (Gen_Name) = N_Expanded_Name loop 2895 Gen_Name := Prefix (Gen_Name); 2896 end loop; 2897 2898 if Chars (Gen_Name) = Chars (Pack_Id) then 2899 Error_Msg_NE 2900 ("& is hidden within declaration of formal package", 2901 Gen_Id, Gen_Name); 2902 end if; 2903 end; 2904 2905 if Box_Present (N) 2906 or else No (Generic_Associations (N)) 2907 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2908 then 2909 Associations := False; 2910 end if; 2911 2912 -- If there are no generic associations, the generic parameters appear 2913 -- as local entities and are instantiated like them. We copy the generic 2914 -- package declaration as if it were an instantiation, and analyze it 2915 -- like a regular package, except that we treat the formals as 2916 -- additional visible components. 2917 2918 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2919 2920 if In_Extended_Main_Source_Unit (N) then 2921 Set_Is_Instantiated (Gen_Unit); 2922 Generate_Reference (Gen_Unit, N); 2923 end if; 2924 2925 Formal := New_Copy (Pack_Id); 2926 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 2927 2928 -- Make local generic without formals. The formals will be replaced with 2929 -- internal declarations. 2930 2931 begin 2932 New_N := Build_Local_Package; 2933 2934 -- If there are errors in the parameter list, Analyze_Associations 2935 -- raises Instantiation_Error. Patch the declaration to prevent further 2936 -- exception propagation. 2937 2938 exception 2939 when Instantiation_Error => 2940 Enter_Name (Formal); 2941 Set_Ekind (Formal, E_Variable); 2942 Set_Etype (Formal, Any_Type); 2943 Restore_Hidden_Primitives (Vis_Prims_List); 2944 2945 if Parent_Installed then 2946 Remove_Parent; 2947 end if; 2948 2949 goto Leave; 2950 end; 2951 2952 Rewrite (N, New_N); 2953 Set_Defining_Unit_Name (Specification (New_N), Formal); 2954 Set_Generic_Parent (Specification (N), Gen_Unit); 2955 Set_Instance_Env (Gen_Unit, Formal); 2956 Set_Is_Generic_Instance (Formal); 2957 2958 Enter_Name (Formal); 2959 Set_Ekind (Formal, E_Package); 2960 Set_Etype (Formal, Standard_Void_Type); 2961 Set_Inner_Instances (Formal, New_Elmt_List); 2962 Push_Scope (Formal); 2963 2964 -- Manually set the SPARK_Mode from the context because the package 2965 -- declaration is never analyzed. 2966 2967 Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma); 2968 Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma); 2969 Set_SPARK_Pragma_Inherited (Formal); 2970 Set_SPARK_Aux_Pragma_Inherited (Formal); 2971 2972 if Is_Child_Unit (Gen_Unit) and then Parent_Installed then 2973 2974 -- Similarly, we have to make the name of the formal visible in the 2975 -- parent instance, to resolve properly fully qualified names that 2976 -- may appear in the generic unit. The parent instance has been 2977 -- placed on the scope stack ahead of the current scope. 2978 2979 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2980 2981 Renaming_In_Par := 2982 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2983 Set_Ekind (Renaming_In_Par, E_Package); 2984 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2985 Set_Scope (Renaming_In_Par, Parent_Instance); 2986 Set_Parent (Renaming_In_Par, Parent (Formal)); 2987 Set_Renamed_Object (Renaming_In_Par, Formal); 2988 Append_Entity (Renaming_In_Par, Parent_Instance); 2989 end if; 2990 2991 -- A formal package declaration behaves as a package instantiation with 2992 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether 2993 -- missing, set the global flag which signals Analyze_Pragma to ingnore 2994 -- all SPARK_Mode pragmas within the generic_package_name. 2995 2996 if SPARK_Mode /= On then 2997 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 2998 2999 -- Mark the formal spec in case the body is instantiated at a later 3000 -- pass. This preserves the original context in effect for the body. 3001 3002 Set_Ignore_SPARK_Mode_Pragmas (Formal); 3003 end if; 3004 3005 Analyze (Specification (N)); 3006 3007 -- The formals for which associations are provided are not visible 3008 -- outside of the formal package. The others are still declared by a 3009 -- formal parameter declaration. 3010 3011 -- If there are no associations, the only local entity to hide is the 3012 -- generated package renaming itself. 3013 3014 declare 3015 E : Entity_Id; 3016 3017 begin 3018 E := First_Entity (Formal); 3019 while Present (E) loop 3020 if Associations and then not Is_Generic_Formal (E) then 3021 Set_Is_Hidden (E); 3022 end if; 3023 3024 if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then 3025 Set_Is_Hidden (E); 3026 exit; 3027 end if; 3028 3029 Next_Entity (E); 3030 end loop; 3031 end; 3032 3033 End_Package_Scope (Formal); 3034 Restore_Hidden_Primitives (Vis_Prims_List); 3035 3036 if Parent_Installed then 3037 Remove_Parent; 3038 end if; 3039 3040 Restore_Env; 3041 3042 -- Inside the generic unit, the formal package is a regular package, but 3043 -- no body is needed for it. Note that after instantiation, the defining 3044 -- unit name we need is in the new tree and not in the original (see 3045 -- Package_Instantiation). A generic formal package is an instance, and 3046 -- can be used as an actual for an inner instance. 3047 3048 Set_Has_Completion (Formal, True); 3049 3050 -- Add semantic information to the original defining identifier for ASIS 3051 -- use. 3052 3053 Set_Ekind (Pack_Id, E_Package); 3054 Set_Etype (Pack_Id, Standard_Void_Type); 3055 Set_Scope (Pack_Id, Scope (Formal)); 3056 Set_Has_Completion (Pack_Id, True); 3057 3058 <<Leave>> 3059 if Has_Aspects (N) then 3060 Analyze_Aspect_Specifications (N, Pack_Id); 3061 end if; 3062 3063 Ignore_SPARK_Mode_Pragmas_In_Instance := Save_ISMP; 3064 end Analyze_Formal_Package_Declaration; 3065 3066 --------------------------------- 3067 -- Analyze_Formal_Private_Type -- 3068 --------------------------------- 3069 3070 procedure Analyze_Formal_Private_Type 3071 (N : Node_Id; 3072 T : Entity_Id; 3073 Def : Node_Id) 3074 is 3075 begin 3076 New_Private_Type (N, T, Def); 3077 3078 -- Set the size to an arbitrary but legal value 3079 3080 Set_Size_Info (T, Standard_Integer); 3081 Set_RM_Size (T, RM_Size (Standard_Integer)); 3082 end Analyze_Formal_Private_Type; 3083 3084 ------------------------------------ 3085 -- Analyze_Formal_Incomplete_Type -- 3086 ------------------------------------ 3087 3088 procedure Analyze_Formal_Incomplete_Type 3089 (T : Entity_Id; 3090 Def : Node_Id) 3091 is 3092 begin 3093 Enter_Name (T); 3094 Set_Ekind (T, E_Incomplete_Type); 3095 Set_Etype (T, T); 3096 Set_Private_Dependents (T, New_Elmt_List); 3097 3098 if Tagged_Present (Def) then 3099 Set_Is_Tagged_Type (T); 3100 Make_Class_Wide_Type (T); 3101 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3102 end if; 3103 end Analyze_Formal_Incomplete_Type; 3104 3105 ---------------------------------------- 3106 -- Analyze_Formal_Signed_Integer_Type -- 3107 ---------------------------------------- 3108 3109 procedure Analyze_Formal_Signed_Integer_Type 3110 (T : Entity_Id; 3111 Def : Node_Id) 3112 is 3113 Base : constant Entity_Id := 3114 New_Internal_Entity 3115 (E_Signed_Integer_Type, 3116 Current_Scope, 3117 Sloc (Defining_Identifier (Parent (Def))), 'G'); 3118 3119 begin 3120 Enter_Name (T); 3121 3122 Set_Ekind (T, E_Signed_Integer_Subtype); 3123 Set_Etype (T, Base); 3124 Set_Size_Info (T, Standard_Integer); 3125 Set_RM_Size (T, RM_Size (Standard_Integer)); 3126 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 3127 Set_Is_Constrained (T); 3128 3129 Set_Is_Generic_Type (Base); 3130 Set_Size_Info (Base, Standard_Integer); 3131 Set_RM_Size (Base, RM_Size (Standard_Integer)); 3132 Set_Etype (Base, Base); 3133 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 3134 Set_Parent (Base, Parent (Def)); 3135 end Analyze_Formal_Signed_Integer_Type; 3136 3137 ------------------------------------------- 3138 -- Analyze_Formal_Subprogram_Declaration -- 3139 ------------------------------------------- 3140 3141 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 3142 Spec : constant Node_Id := Specification (N); 3143 Def : constant Node_Id := Default_Name (N); 3144 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 3145 Subp : Entity_Id; 3146 3147 begin 3148 if Nam = Error then 3149 return; 3150 end if; 3151 3152 if Nkind (Nam) = N_Defining_Program_Unit_Name then 3153 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 3154 goto Leave; 3155 end if; 3156 3157 Analyze_Subprogram_Declaration (N); 3158 Set_Is_Formal_Subprogram (Nam); 3159 Set_Has_Completion (Nam); 3160 3161 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 3162 Set_Is_Abstract_Subprogram (Nam); 3163 3164 Set_Is_Dispatching_Operation (Nam); 3165 3166 -- A formal abstract procedure cannot have a null default 3167 -- (RM 12.6(4.1/2)). 3168 3169 if Nkind (Spec) = N_Procedure_Specification 3170 and then Null_Present (Spec) 3171 then 3172 Error_Msg_N 3173 ("a formal abstract subprogram cannot default to null", Spec); 3174 end if; 3175 3176 declare 3177 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 3178 begin 3179 if No (Ctrl_Type) then 3180 Error_Msg_N 3181 ("abstract formal subprogram must have a controlling type", 3182 N); 3183 3184 elsif Ada_Version >= Ada_2012 3185 and then Is_Incomplete_Type (Ctrl_Type) 3186 then 3187 Error_Msg_NE 3188 ("controlling type of abstract formal subprogram cannot " 3189 & "be incomplete type", N, Ctrl_Type); 3190 3191 else 3192 Check_Controlling_Formals (Ctrl_Type, Nam); 3193 end if; 3194 end; 3195 end if; 3196 3197 -- Default name is resolved at the point of instantiation 3198 3199 if Box_Present (N) then 3200 null; 3201 3202 -- Else default is bound at the point of generic declaration 3203 3204 elsif Present (Def) then 3205 if Nkind (Def) = N_Operator_Symbol then 3206 Find_Direct_Name (Def); 3207 3208 elsif Nkind (Def) /= N_Attribute_Reference then 3209 Analyze (Def); 3210 3211 else 3212 -- For an attribute reference, analyze the prefix and verify 3213 -- that it has the proper profile for the subprogram. 3214 3215 Analyze (Prefix (Def)); 3216 Valid_Default_Attribute (Nam, Def); 3217 goto Leave; 3218 end if; 3219 3220 -- Default name may be overloaded, in which case the interpretation 3221 -- with the correct profile must be selected, as for a renaming. 3222 -- If the definition is an indexed component, it must denote a 3223 -- member of an entry family. If it is a selected component, it 3224 -- can be a protected operation. 3225 3226 if Etype (Def) = Any_Type then 3227 goto Leave; 3228 3229 elsif Nkind (Def) = N_Selected_Component then 3230 if not Is_Overloadable (Entity (Selector_Name (Def))) then 3231 Error_Msg_N ("expect valid subprogram name as default", Def); 3232 end if; 3233 3234 elsif Nkind (Def) = N_Indexed_Component then 3235 if Is_Entity_Name (Prefix (Def)) then 3236 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 3237 Error_Msg_N ("expect valid subprogram name as default", Def); 3238 end if; 3239 3240 elsif Nkind (Prefix (Def)) = N_Selected_Component then 3241 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 3242 E_Entry_Family 3243 then 3244 Error_Msg_N ("expect valid subprogram name as default", Def); 3245 end if; 3246 3247 else 3248 Error_Msg_N ("expect valid subprogram name as default", Def); 3249 goto Leave; 3250 end if; 3251 3252 elsif Nkind (Def) = N_Character_Literal then 3253 3254 -- Needs some type checks: subprogram should be parameterless??? 3255 3256 Resolve (Def, (Etype (Nam))); 3257 3258 elsif not Is_Entity_Name (Def) 3259 or else not Is_Overloadable (Entity (Def)) 3260 then 3261 Error_Msg_N ("expect valid subprogram name as default", Def); 3262 goto Leave; 3263 3264 elsif not Is_Overloaded (Def) then 3265 Subp := Entity (Def); 3266 3267 if Subp = Nam then 3268 Error_Msg_N ("premature usage of formal subprogram", Def); 3269 3270 elsif not Entity_Matches_Spec (Subp, Nam) then 3271 Error_Msg_N ("no visible entity matches specification", Def); 3272 end if; 3273 3274 -- More than one interpretation, so disambiguate as for a renaming 3275 3276 else 3277 declare 3278 I : Interp_Index; 3279 I1 : Interp_Index := 0; 3280 It : Interp; 3281 It1 : Interp; 3282 3283 begin 3284 Subp := Any_Id; 3285 Get_First_Interp (Def, I, It); 3286 while Present (It.Nam) loop 3287 if Entity_Matches_Spec (It.Nam, Nam) then 3288 if Subp /= Any_Id then 3289 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 3290 3291 if It1 = No_Interp then 3292 Error_Msg_N ("ambiguous default subprogram", Def); 3293 else 3294 Subp := It1.Nam; 3295 end if; 3296 3297 exit; 3298 3299 else 3300 I1 := I; 3301 Subp := It.Nam; 3302 end if; 3303 end if; 3304 3305 Get_Next_Interp (I, It); 3306 end loop; 3307 end; 3308 3309 if Subp /= Any_Id then 3310 3311 -- Subprogram found, generate reference to it 3312 3313 Set_Entity (Def, Subp); 3314 Generate_Reference (Subp, Def); 3315 3316 if Subp = Nam then 3317 Error_Msg_N ("premature usage of formal subprogram", Def); 3318 3319 elsif Ekind (Subp) /= E_Operator then 3320 Check_Mode_Conformant (Subp, Nam); 3321 end if; 3322 3323 else 3324 Error_Msg_N ("no visible subprogram matches specification", N); 3325 end if; 3326 end if; 3327 end if; 3328 3329 <<Leave>> 3330 if Has_Aspects (N) then 3331 Analyze_Aspect_Specifications (N, Nam); 3332 end if; 3333 3334 end Analyze_Formal_Subprogram_Declaration; 3335 3336 ------------------------------------- 3337 -- Analyze_Formal_Type_Declaration -- 3338 ------------------------------------- 3339 3340 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 3341 Def : constant Node_Id := Formal_Type_Definition (N); 3342 T : Entity_Id; 3343 3344 begin 3345 T := Defining_Identifier (N); 3346 3347 if Present (Discriminant_Specifications (N)) 3348 and then Nkind (Def) /= N_Formal_Private_Type_Definition 3349 then 3350 Error_Msg_N 3351 ("discriminants not allowed for this formal type", T); 3352 end if; 3353 3354 -- Enter the new name, and branch to specific routine 3355 3356 case Nkind (Def) is 3357 when N_Formal_Private_Type_Definition => 3358 Analyze_Formal_Private_Type (N, T, Def); 3359 3360 when N_Formal_Derived_Type_Definition => 3361 Analyze_Formal_Derived_Type (N, T, Def); 3362 3363 when N_Formal_Incomplete_Type_Definition => 3364 Analyze_Formal_Incomplete_Type (T, Def); 3365 3366 when N_Formal_Discrete_Type_Definition => 3367 Analyze_Formal_Discrete_Type (T, Def); 3368 3369 when N_Formal_Signed_Integer_Type_Definition => 3370 Analyze_Formal_Signed_Integer_Type (T, Def); 3371 3372 when N_Formal_Modular_Type_Definition => 3373 Analyze_Formal_Modular_Type (T, Def); 3374 3375 when N_Formal_Floating_Point_Definition => 3376 Analyze_Formal_Floating_Type (T, Def); 3377 3378 when N_Formal_Ordinary_Fixed_Point_Definition => 3379 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 3380 3381 when N_Formal_Decimal_Fixed_Point_Definition => 3382 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 3383 3384 when N_Array_Type_Definition => 3385 Analyze_Formal_Array_Type (T, Def); 3386 3387 when N_Access_Function_Definition 3388 | N_Access_Procedure_Definition 3389 | N_Access_To_Object_Definition 3390 => 3391 Analyze_Generic_Access_Type (T, Def); 3392 3393 -- Ada 2005: a interface declaration is encoded as an abstract 3394 -- record declaration or a abstract type derivation. 3395 3396 when N_Record_Definition => 3397 Analyze_Formal_Interface_Type (N, T, Def); 3398 3399 when N_Derived_Type_Definition => 3400 Analyze_Formal_Derived_Interface_Type (N, T, Def); 3401 3402 when N_Error => 3403 null; 3404 3405 when others => 3406 raise Program_Error; 3407 end case; 3408 3409 Set_Is_Generic_Type (T); 3410 3411 if Has_Aspects (N) then 3412 Analyze_Aspect_Specifications (N, T); 3413 end if; 3414 end Analyze_Formal_Type_Declaration; 3415 3416 ------------------------------------ 3417 -- Analyze_Function_Instantiation -- 3418 ------------------------------------ 3419 3420 procedure Analyze_Function_Instantiation (N : Node_Id) is 3421 begin 3422 Analyze_Subprogram_Instantiation (N, E_Function); 3423 end Analyze_Function_Instantiation; 3424 3425 --------------------------------- 3426 -- Analyze_Generic_Access_Type -- 3427 --------------------------------- 3428 3429 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 3430 begin 3431 Enter_Name (T); 3432 3433 if Nkind (Def) = N_Access_To_Object_Definition then 3434 Access_Type_Declaration (T, Def); 3435 3436 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 3437 and then No (Full_View (Designated_Type (T))) 3438 and then not Is_Generic_Type (Designated_Type (T)) 3439 then 3440 Error_Msg_N ("premature usage of incomplete type", Def); 3441 3442 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 3443 Error_Msg_N 3444 ("only a subtype mark is allowed in a formal", Def); 3445 end if; 3446 3447 else 3448 Access_Subprogram_Declaration (T, Def); 3449 end if; 3450 end Analyze_Generic_Access_Type; 3451 3452 --------------------------------- 3453 -- Analyze_Generic_Formal_Part -- 3454 --------------------------------- 3455 3456 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 3457 Gen_Parm_Decl : Node_Id; 3458 3459 begin 3460 -- The generic formals are processed in the scope of the generic unit, 3461 -- where they are immediately visible. The scope is installed by the 3462 -- caller. 3463 3464 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 3465 while Present (Gen_Parm_Decl) loop 3466 Analyze (Gen_Parm_Decl); 3467 Next (Gen_Parm_Decl); 3468 end loop; 3469 3470 Generate_Reference_To_Generic_Formals (Current_Scope); 3471 end Analyze_Generic_Formal_Part; 3472 3473 ------------------------------------------ 3474 -- Analyze_Generic_Package_Declaration -- 3475 ------------------------------------------ 3476 3477 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 3478 Decls : constant List_Id := Visible_Declarations (Specification (N)); 3479 Loc : constant Source_Ptr := Sloc (N); 3480 3481 Decl : Node_Id; 3482 Id : Entity_Id; 3483 New_N : Node_Id; 3484 Renaming : Node_Id; 3485 Save_Parent : Node_Id; 3486 3487 begin 3488 Check_SPARK_05_Restriction ("generic is not allowed", N); 3489 3490 -- We introduce a renaming of the enclosing package, to have a usable 3491 -- entity as the prefix of an expanded name for a local entity of the 3492 -- form Par.P.Q, where P is the generic package. This is because a local 3493 -- entity named P may hide it, so that the usual visibility rules in 3494 -- the instance will not resolve properly. 3495 3496 Renaming := 3497 Make_Package_Renaming_Declaration (Loc, 3498 Defining_Unit_Name => 3499 Make_Defining_Identifier (Loc, 3500 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 3501 Name => 3502 Make_Identifier (Loc, Chars (Defining_Entity (N)))); 3503 3504 -- The declaration is inserted before other declarations, but before 3505 -- pragmas that may be library-unit pragmas and must appear before other 3506 -- declarations. The pragma Compile_Time_Error is not in this class, and 3507 -- may contain an expression that includes such a qualified name, so the 3508 -- renaming declaration must appear before it. 3509 3510 -- Are there other pragmas that require this special handling ??? 3511 3512 if Present (Decls) then 3513 Decl := First (Decls); 3514 while Present (Decl) 3515 and then Nkind (Decl) = N_Pragma 3516 and then Get_Pragma_Id (Decl) /= Pragma_Compile_Time_Error 3517 loop 3518 Next (Decl); 3519 end loop; 3520 3521 if Present (Decl) then 3522 Insert_Before (Decl, Renaming); 3523 else 3524 Append (Renaming, Visible_Declarations (Specification (N))); 3525 end if; 3526 3527 else 3528 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3529 end if; 3530 3531 -- Create copy of generic unit, and save for instantiation. If the unit 3532 -- is a child unit, do not copy the specifications for the parent, which 3533 -- are not part of the generic tree. 3534 3535 Save_Parent := Parent_Spec (N); 3536 Set_Parent_Spec (N, Empty); 3537 3538 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3539 Set_Parent_Spec (New_N, Save_Parent); 3540 Rewrite (N, New_N); 3541 3542 -- Once the contents of the generic copy and the template are swapped, 3543 -- do the same for their respective aspect specifications. 3544 3545 Exchange_Aspects (N, New_N); 3546 3547 -- Collect all contract-related source pragmas found within the template 3548 -- and attach them to the contract of the package spec. This contract is 3549 -- used in the capture of global references within annotations. 3550 3551 Create_Generic_Contract (N); 3552 3553 Id := Defining_Entity (N); 3554 Generate_Definition (Id); 3555 3556 -- Expansion is not applied to generic units 3557 3558 Start_Generic; 3559 3560 Enter_Name (Id); 3561 Set_Ekind (Id, E_Generic_Package); 3562 Set_Etype (Id, Standard_Void_Type); 3563 3564 -- Set SPARK_Mode from context 3565 3566 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3567 Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); 3568 Set_SPARK_Pragma_Inherited (Id); 3569 Set_SPARK_Aux_Pragma_Inherited (Id); 3570 3571 -- Preserve relevant elaboration-related attributes of the context which 3572 -- are no longer available or very expensive to recompute once analysis, 3573 -- resolution, and expansion are over. 3574 3575 Mark_Elaboration_Attributes 3576 (N_Id => Id, 3577 Checks => True); 3578 3579 -- Analyze aspects now, so that generated pragmas appear in the 3580 -- declarations before building and analyzing the generic copy. 3581 3582 if Has_Aspects (N) then 3583 Analyze_Aspect_Specifications (N, Id); 3584 end if; 3585 3586 Push_Scope (Id); 3587 Enter_Generic_Scope (Id); 3588 Set_Inner_Instances (Id, New_Elmt_List); 3589 3590 Set_Categorization_From_Pragmas (N); 3591 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3592 3593 -- Link the declaration of the generic homonym in the generic copy to 3594 -- the package it renames, so that it is always resolved properly. 3595 3596 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3597 Set_Entity (Associated_Node (Name (Renaming)), Id); 3598 3599 -- For a library unit, we have reconstructed the entity for the unit, 3600 -- and must reset it in the library tables. 3601 3602 if Nkind (Parent (N)) = N_Compilation_Unit then 3603 Set_Cunit_Entity (Current_Sem_Unit, Id); 3604 end if; 3605 3606 Analyze_Generic_Formal_Part (N); 3607 3608 -- After processing the generic formals, analysis proceeds as for a 3609 -- non-generic package. 3610 3611 Analyze (Specification (N)); 3612 3613 Validate_Categorization_Dependency (N, Id); 3614 3615 End_Generic; 3616 3617 End_Package_Scope (Id); 3618 Exit_Generic_Scope (Id); 3619 3620 -- If the generic appears within a package unit, the body of that unit 3621 -- has to be present for instantiation and inlining. 3622 3623 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration then 3624 Set_Body_Needed_For_Inlining 3625 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3626 end if; 3627 3628 if Nkind (Parent (N)) /= N_Compilation_Unit then 3629 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3630 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3631 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3632 3633 else 3634 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3635 Validate_RT_RAT_Component (N); 3636 3637 -- If this is a spec without a body, check that generic parameters 3638 -- are referenced. 3639 3640 if not Body_Required (Parent (N)) then 3641 Check_References (Id); 3642 end if; 3643 end if; 3644 3645 -- If there is a specified storage pool in the context, create an 3646 -- aspect on the package declaration, so that it is used in any 3647 -- instance that does not override it. 3648 3649 if Present (Default_Pool) then 3650 declare 3651 ASN : Node_Id; 3652 3653 begin 3654 ASN := 3655 Make_Aspect_Specification (Loc, 3656 Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), 3657 Expression => New_Copy (Default_Pool)); 3658 3659 if No (Aspect_Specifications (Specification (N))) then 3660 Set_Aspect_Specifications (Specification (N), New_List (ASN)); 3661 else 3662 Append (ASN, Aspect_Specifications (Specification (N))); 3663 end if; 3664 end; 3665 end if; 3666 end Analyze_Generic_Package_Declaration; 3667 3668 -------------------------------------------- 3669 -- Analyze_Generic_Subprogram_Declaration -- 3670 -------------------------------------------- 3671 3672 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3673 Formals : List_Id; 3674 Id : Entity_Id; 3675 New_N : Node_Id; 3676 Result_Type : Entity_Id; 3677 Save_Parent : Node_Id; 3678 Spec : Node_Id; 3679 Typ : Entity_Id; 3680 3681 begin 3682 Check_SPARK_05_Restriction ("generic is not allowed", N); 3683 3684 -- Create copy of generic unit, and save for instantiation. If the unit 3685 -- is a child unit, do not copy the specifications for the parent, which 3686 -- are not part of the generic tree. 3687 3688 Save_Parent := Parent_Spec (N); 3689 Set_Parent_Spec (N, Empty); 3690 3691 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3692 Set_Parent_Spec (New_N, Save_Parent); 3693 Rewrite (N, New_N); 3694 3695 -- Once the contents of the generic copy and the template are swapped, 3696 -- do the same for their respective aspect specifications. 3697 3698 Exchange_Aspects (N, New_N); 3699 3700 -- Collect all contract-related source pragmas found within the template 3701 -- and attach them to the contract of the subprogram spec. This contract 3702 -- is used in the capture of global references within annotations. 3703 3704 Create_Generic_Contract (N); 3705 3706 Spec := Specification (N); 3707 Id := Defining_Entity (Spec); 3708 Generate_Definition (Id); 3709 3710 if Nkind (Id) = N_Defining_Operator_Symbol then 3711 Error_Msg_N 3712 ("operator symbol not allowed for generic subprogram", Id); 3713 end if; 3714 3715 Start_Generic; 3716 3717 Enter_Name (Id); 3718 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3719 3720 -- Analyze the aspects of the generic copy to ensure that all generated 3721 -- pragmas (if any) perform their semantic effects. 3722 3723 if Has_Aspects (N) then 3724 Analyze_Aspect_Specifications (N, Id); 3725 end if; 3726 3727 Push_Scope (Id); 3728 Enter_Generic_Scope (Id); 3729 Set_Inner_Instances (Id, New_Elmt_List); 3730 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3731 3732 Analyze_Generic_Formal_Part (N); 3733 3734 if Nkind (Spec) = N_Function_Specification then 3735 Set_Ekind (Id, E_Generic_Function); 3736 else 3737 Set_Ekind (Id, E_Generic_Procedure); 3738 end if; 3739 3740 -- Set SPARK_Mode from context 3741 3742 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3743 Set_SPARK_Pragma_Inherited (Id); 3744 3745 -- Preserve relevant elaboration-related attributes of the context which 3746 -- are no longer available or very expensive to recompute once analysis, 3747 -- resolution, and expansion are over. 3748 3749 Mark_Elaboration_Attributes 3750 (N_Id => Id, 3751 Checks => True); 3752 3753 Formals := Parameter_Specifications (Spec); 3754 3755 if Present (Formals) then 3756 Process_Formals (Formals, Spec); 3757 end if; 3758 3759 if Nkind (Spec) = N_Function_Specification then 3760 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3761 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3762 Set_Etype (Id, Result_Type); 3763 3764 -- Check restriction imposed by AI05-073: a generic function 3765 -- cannot return an abstract type or an access to such. 3766 3767 -- This is a binding interpretation should it apply to earlier 3768 -- versions of Ada as well as Ada 2012??? 3769 3770 if Is_Abstract_Type (Designated_Type (Result_Type)) 3771 and then Ada_Version >= Ada_2012 3772 then 3773 Error_Msg_N 3774 ("generic function cannot have an access result " 3775 & "that designates an abstract type", Spec); 3776 end if; 3777 3778 else 3779 Find_Type (Result_Definition (Spec)); 3780 Typ := Entity (Result_Definition (Spec)); 3781 3782 if Is_Abstract_Type (Typ) 3783 and then Ada_Version >= Ada_2012 3784 then 3785 Error_Msg_N 3786 ("generic function cannot have abstract result type", Spec); 3787 end if; 3788 3789 -- If a null exclusion is imposed on the result type, then create 3790 -- a null-excluding itype (an access subtype) and use it as the 3791 -- function's Etype. 3792 3793 if Is_Access_Type (Typ) 3794 and then Null_Exclusion_Present (Spec) 3795 then 3796 Set_Etype (Id, 3797 Create_Null_Excluding_Itype 3798 (T => Typ, 3799 Related_Nod => Spec, 3800 Scope_Id => Defining_Unit_Name (Spec))); 3801 else 3802 Set_Etype (Id, Typ); 3803 end if; 3804 end if; 3805 3806 else 3807 Set_Etype (Id, Standard_Void_Type); 3808 end if; 3809 3810 -- For a library unit, we have reconstructed the entity for the unit, 3811 -- and must reset it in the library tables. We also make sure that 3812 -- Body_Required is set properly in the original compilation unit node. 3813 3814 if Nkind (Parent (N)) = N_Compilation_Unit then 3815 Set_Cunit_Entity (Current_Sem_Unit, Id); 3816 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3817 end if; 3818 3819 -- If the generic appears within a package unit, the body of that unit 3820 -- has to be present for instantiation and inlining. 3821 3822 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 3823 and then Unit_Requires_Body (Id) 3824 then 3825 Set_Body_Needed_For_Inlining 3826 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3827 end if; 3828 3829 Set_Categorization_From_Pragmas (N); 3830 Validate_Categorization_Dependency (N, Id); 3831 3832 -- Capture all global references that occur within the profile of the 3833 -- generic subprogram. Aspects are not part of this processing because 3834 -- they must be delayed. If processed now, Save_Global_References will 3835 -- destroy the Associated_Node links and prevent the capture of global 3836 -- references when the contract of the generic subprogram is analyzed. 3837 3838 Save_Global_References (Original_Node (N)); 3839 3840 End_Generic; 3841 End_Scope; 3842 Exit_Generic_Scope (Id); 3843 Generate_Reference_To_Formals (Id); 3844 3845 List_Inherited_Pre_Post_Aspects (Id); 3846 end Analyze_Generic_Subprogram_Declaration; 3847 3848 ----------------------------------- 3849 -- Analyze_Package_Instantiation -- 3850 ----------------------------------- 3851 3852 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 3853 -- must be replaced by gotos which jump to the end of the routine in order 3854 -- to restore the Ghost and SPARK modes. 3855 3856 procedure Analyze_Package_Instantiation (N : Node_Id) is 3857 Has_Inline_Always : Boolean := False; 3858 3859 procedure Delay_Descriptors (E : Entity_Id); 3860 -- Delay generation of subprogram descriptors for given entity 3861 3862 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean; 3863 -- If inlining is active and the generic contains inlined subprograms, 3864 -- we instantiate the body. This may cause superfluous instantiations, 3865 -- but it is simpler than detecting the need for the body at the point 3866 -- of inlining, when the context of the instance is not available. 3867 3868 ----------------------- 3869 -- Delay_Descriptors -- 3870 ----------------------- 3871 3872 procedure Delay_Descriptors (E : Entity_Id) is 3873 begin 3874 if not Delay_Subprogram_Descriptors (E) then 3875 Set_Delay_Subprogram_Descriptors (E); 3876 Pending_Descriptor.Append (E); 3877 end if; 3878 end Delay_Descriptors; 3879 3880 ----------------------- 3881 -- Might_Inline_Subp -- 3882 ----------------------- 3883 3884 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean is 3885 E : Entity_Id; 3886 3887 begin 3888 if not Inline_Processing_Required then 3889 return False; 3890 3891 else 3892 E := First_Entity (Gen_Unit); 3893 while Present (E) loop 3894 if Is_Subprogram (E) and then Is_Inlined (E) then 3895 -- Remember if there are any subprograms with Inline_Always 3896 3897 if Has_Pragma_Inline_Always (E) then 3898 Has_Inline_Always := True; 3899 end if; 3900 3901 return True; 3902 end if; 3903 3904 Next_Entity (E); 3905 end loop; 3906 end if; 3907 3908 return False; 3909 end Might_Inline_Subp; 3910 3911 -- Local declarations 3912 3913 Gen_Id : constant Node_Id := Name (N); 3914 Is_Actual_Pack : constant Boolean := 3915 Is_Internal (Defining_Entity (N)); 3916 Loc : constant Source_Ptr := Sloc (N); 3917 3918 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3919 Saved_ISMP : constant Boolean := 3920 Ignore_SPARK_Mode_Pragmas_In_Instance; 3921 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 3922 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 3923 -- Save the Ghost and SPARK mode-related data to restore on exit 3924 3925 Saved_Style_Check : constant Boolean := Style_Check; 3926 -- Save style check mode for restore on exit 3927 3928 Act_Decl : Node_Id; 3929 Act_Decl_Name : Node_Id; 3930 Act_Decl_Id : Entity_Id; 3931 Act_Spec : Node_Id; 3932 Act_Tree : Node_Id; 3933 Env_Installed : Boolean := False; 3934 Gen_Decl : Node_Id; 3935 Gen_Spec : Node_Id; 3936 Gen_Unit : Entity_Id; 3937 Inline_Now : Boolean := False; 3938 Needs_Body : Boolean; 3939 Parent_Installed : Boolean := False; 3940 Renaming_List : List_Id; 3941 Unit_Renaming : Node_Id; 3942 3943 Vis_Prims_List : Elist_Id := No_Elist; 3944 -- List of primitives made temporarily visible in the instantiation 3945 -- to match the visibility of the formal type 3946 3947 -- Start of processing for Analyze_Package_Instantiation 3948 3949 begin 3950 -- Preserve relevant elaboration-related attributes of the context which 3951 -- are no longer available or very expensive to recompute once analysis, 3952 -- resolution, and expansion are over. 3953 3954 Mark_Elaboration_Attributes 3955 (N_Id => N, 3956 Checks => True, 3957 Level => True, 3958 Modes => True, 3959 Warnings => True); 3960 3961 Check_SPARK_05_Restriction ("generic is not allowed", N); 3962 3963 -- Very first thing: check for Text_IO special unit in case we are 3964 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. 3965 3966 Check_Text_IO_Special_Unit (Name (N)); 3967 3968 -- Make node global for error reporting 3969 3970 Instantiation_Node := N; 3971 3972 -- Case of instantiation of a generic package 3973 3974 if Nkind (N) = N_Package_Instantiation then 3975 Act_Decl_Id := New_Copy (Defining_Entity (N)); 3976 Set_Comes_From_Source (Act_Decl_Id, True); 3977 3978 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 3979 Act_Decl_Name := 3980 Make_Defining_Program_Unit_Name (Loc, 3981 Name => 3982 New_Copy_Tree (Name (Defining_Unit_Name (N))), 3983 Defining_Identifier => Act_Decl_Id); 3984 else 3985 Act_Decl_Name := Act_Decl_Id; 3986 end if; 3987 3988 -- Case of instantiation of a formal package 3989 3990 else 3991 Act_Decl_Id := Defining_Identifier (N); 3992 Act_Decl_Name := Act_Decl_Id; 3993 end if; 3994 3995 Generate_Definition (Act_Decl_Id); 3996 Set_Ekind (Act_Decl_Id, E_Package); 3997 3998 -- Initialize list of incomplete actuals before analysis 3999 4000 Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List); 4001 4002 Preanalyze_Actuals (N, Act_Decl_Id); 4003 4004 -- Turn off style checking in instances. If the check is enabled on the 4005 -- generic unit, a warning in an instance would just be noise. If not 4006 -- enabled on the generic, then a warning in an instance is just wrong. 4007 -- This must be done after analyzing the actuals, which do come from 4008 -- source and are subject to style checking. 4009 4010 Style_Check := False; 4011 4012 Init_Env; 4013 Env_Installed := True; 4014 4015 -- Reset renaming map for formal types. The mapping is established 4016 -- when analyzing the generic associations, but some mappings are 4017 -- inherited from formal packages of parent units, and these are 4018 -- constructed when the parents are installed. 4019 4020 Generic_Renamings.Set_Last (0); 4021 Generic_Renamings_HTable.Reset; 4022 4023 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 4024 Gen_Unit := Entity (Gen_Id); 4025 4026 -- A package instantiation is Ghost when it is subject to pragma Ghost 4027 -- or the generic template is Ghost. Set the mode now to ensure that 4028 -- any nodes generated during analysis and expansion are marked as 4029 -- Ghost. 4030 4031 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 4032 4033 -- Verify that it is the name of a generic package 4034 4035 -- A visibility glitch: if the instance is a child unit and the generic 4036 -- is the generic unit of a parent instance (i.e. both the parent and 4037 -- the child units are instances of the same package) the name now 4038 -- denotes the renaming within the parent, not the intended generic 4039 -- unit. See if there is a homonym that is the desired generic. The 4040 -- renaming declaration must be visible inside the instance of the 4041 -- child, but not when analyzing the name in the instantiation itself. 4042 4043 if Ekind (Gen_Unit) = E_Package 4044 and then Present (Renamed_Entity (Gen_Unit)) 4045 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 4046 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 4047 and then Present (Homonym (Gen_Unit)) 4048 then 4049 Gen_Unit := Homonym (Gen_Unit); 4050 end if; 4051 4052 if Etype (Gen_Unit) = Any_Type then 4053 Restore_Env; 4054 goto Leave; 4055 4056 elsif Ekind (Gen_Unit) /= E_Generic_Package then 4057 4058 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 4059 4060 if From_Limited_With (Gen_Unit) then 4061 Error_Msg_N 4062 ("cannot instantiate a limited withed package", Gen_Id); 4063 else 4064 Error_Msg_NE 4065 ("& is not the name of a generic package", Gen_Id, Gen_Unit); 4066 end if; 4067 4068 Restore_Env; 4069 goto Leave; 4070 end if; 4071 4072 if In_Extended_Main_Source_Unit (N) then 4073 Set_Is_Instantiated (Gen_Unit); 4074 Generate_Reference (Gen_Unit, N); 4075 4076 if Present (Renamed_Object (Gen_Unit)) then 4077 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 4078 Generate_Reference (Renamed_Object (Gen_Unit), N); 4079 end if; 4080 end if; 4081 4082 if Nkind (Gen_Id) = N_Identifier 4083 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 4084 then 4085 Error_Msg_NE 4086 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 4087 4088 elsif Nkind (Gen_Id) = N_Expanded_Name 4089 and then Is_Child_Unit (Gen_Unit) 4090 and then Nkind (Prefix (Gen_Id)) = N_Identifier 4091 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 4092 then 4093 Error_Msg_N 4094 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 4095 end if; 4096 4097 Set_Entity (Gen_Id, Gen_Unit); 4098 4099 -- If generic is a renaming, get original generic unit 4100 4101 if Present (Renamed_Object (Gen_Unit)) 4102 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 4103 then 4104 Gen_Unit := Renamed_Object (Gen_Unit); 4105 end if; 4106 4107 -- Verify that there are no circular instantiations 4108 4109 if In_Open_Scopes (Gen_Unit) then 4110 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 4111 Restore_Env; 4112 goto Leave; 4113 4114 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 4115 Error_Msg_Node_2 := Current_Scope; 4116 Error_Msg_NE 4117 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 4118 Circularity_Detected := True; 4119 Restore_Env; 4120 goto Leave; 4121 4122 else 4123 -- If the context of the instance is subject to SPARK_Mode "off" or 4124 -- the annotation is altogether missing, set the global flag which 4125 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 4126 -- the instance. 4127 4128 if SPARK_Mode /= On then 4129 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 4130 4131 -- Mark the instance spec in case the body is instantiated at a 4132 -- later pass. This preserves the original context in effect for 4133 -- the body. 4134 4135 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 4136 end if; 4137 4138 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 4139 Gen_Spec := Specification (Gen_Decl); 4140 4141 -- Initialize renamings map, for error checking, and the list that 4142 -- holds private entities whose views have changed between generic 4143 -- definition and instantiation. If this is the instance created to 4144 -- validate an actual package, the instantiation environment is that 4145 -- of the enclosing instance. 4146 4147 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 4148 4149 -- Copy original generic tree, to produce text for instantiation 4150 4151 Act_Tree := 4152 Copy_Generic_Node 4153 (Original_Node (Gen_Decl), Empty, Instantiating => True); 4154 4155 Act_Spec := Specification (Act_Tree); 4156 4157 -- If this is the instance created to validate an actual package, 4158 -- only the formals matter, do not examine the package spec itself. 4159 4160 if Is_Actual_Pack then 4161 Set_Visible_Declarations (Act_Spec, New_List); 4162 Set_Private_Declarations (Act_Spec, New_List); 4163 end if; 4164 4165 Renaming_List := 4166 Analyze_Associations 4167 (I_Node => N, 4168 Formals => Generic_Formal_Declarations (Act_Tree), 4169 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 4170 4171 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 4172 4173 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 4174 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 4175 Set_Is_Generic_Instance (Act_Decl_Id); 4176 Set_Generic_Parent (Act_Spec, Gen_Unit); 4177 4178 -- References to the generic in its own declaration or its body are 4179 -- references to the instance. Add a renaming declaration for the 4180 -- generic unit itself. This declaration, as well as the renaming 4181 -- declarations for the generic formals, must remain private to the 4182 -- unit: the formals, because this is the language semantics, and 4183 -- the unit because its use is an artifact of the implementation. 4184 4185 Unit_Renaming := 4186 Make_Package_Renaming_Declaration (Loc, 4187 Defining_Unit_Name => 4188 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 4189 Name => New_Occurrence_Of (Act_Decl_Id, Loc)); 4190 4191 Append (Unit_Renaming, Renaming_List); 4192 4193 -- The renaming declarations are the first local declarations of the 4194 -- new unit. 4195 4196 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 4197 Insert_List_Before 4198 (First (Visible_Declarations (Act_Spec)), Renaming_List); 4199 else 4200 Set_Visible_Declarations (Act_Spec, Renaming_List); 4201 end if; 4202 4203 Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); 4204 4205 -- Propagate the aspect specifications from the package declaration 4206 -- template to the instantiated version of the package declaration. 4207 4208 if Has_Aspects (Act_Tree) then 4209 Set_Aspect_Specifications (Act_Decl, 4210 New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); 4211 end if; 4212 4213 -- The generic may have a generated Default_Storage_Pool aspect, 4214 -- set at the point of generic declaration. If the instance has 4215 -- that aspect, it overrides the one inherited from the generic. 4216 4217 if Has_Aspects (Gen_Spec) then 4218 if No (Aspect_Specifications (N)) then 4219 Set_Aspect_Specifications (N, 4220 (New_Copy_List_Tree 4221 (Aspect_Specifications (Gen_Spec)))); 4222 4223 else 4224 declare 4225 ASN1, ASN2 : Node_Id; 4226 4227 begin 4228 ASN1 := First (Aspect_Specifications (N)); 4229 while Present (ASN1) loop 4230 if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool 4231 then 4232 -- If generic carries a default storage pool, remove 4233 -- it in favor of the instance one. 4234 4235 ASN2 := First (Aspect_Specifications (Gen_Spec)); 4236 while Present (ASN2) loop 4237 if Chars (Identifier (ASN2)) = 4238 Name_Default_Storage_Pool 4239 then 4240 Remove (ASN2); 4241 exit; 4242 end if; 4243 4244 Next (ASN2); 4245 end loop; 4246 end if; 4247 4248 Next (ASN1); 4249 end loop; 4250 4251 Prepend_List_To (Aspect_Specifications (N), 4252 (New_Copy_List_Tree 4253 (Aspect_Specifications (Gen_Spec)))); 4254 end; 4255 end if; 4256 end if; 4257 4258 -- Save the instantiation node, for subsequent instantiation of the 4259 -- body, if there is one and we are generating code for the current 4260 -- unit. Mark unit as having a body (avoids premature error message). 4261 4262 -- We instantiate the body if we are generating code, if we are 4263 -- generating cross-reference information, or if we are building 4264 -- trees for ASIS use or GNATprove use. 4265 4266 declare 4267 Enclosing_Body_Present : Boolean := False; 4268 -- If the generic unit is not a compilation unit, then a body may 4269 -- be present in its parent even if none is required. We create a 4270 -- tentative pending instantiation for the body, which will be 4271 -- discarded if none is actually present. 4272 4273 Scop : Entity_Id; 4274 4275 begin 4276 if Scope (Gen_Unit) /= Standard_Standard 4277 and then not Is_Child_Unit (Gen_Unit) 4278 then 4279 Scop := Scope (Gen_Unit); 4280 while Present (Scop) and then Scop /= Standard_Standard loop 4281 if Unit_Requires_Body (Scop) then 4282 Enclosing_Body_Present := True; 4283 exit; 4284 4285 elsif In_Open_Scopes (Scop) 4286 and then In_Package_Body (Scop) 4287 then 4288 Enclosing_Body_Present := True; 4289 exit; 4290 end if; 4291 4292 exit when Is_Compilation_Unit (Scop); 4293 Scop := Scope (Scop); 4294 end loop; 4295 end if; 4296 4297 -- If front-end inlining is enabled or there are any subprograms 4298 -- marked with Inline_Always, and this is a unit for which code 4299 -- will be generated, we instantiate the body at once. 4300 4301 -- This is done if the instance is not the main unit, and if the 4302 -- generic is not a child unit of another generic, to avoid scope 4303 -- problems and the reinstallation of parent instances. 4304 4305 if Expander_Active 4306 and then (not Is_Child_Unit (Gen_Unit) 4307 or else not Is_Generic_Unit (Scope (Gen_Unit))) 4308 and then Might_Inline_Subp (Gen_Unit) 4309 and then not Is_Actual_Pack 4310 then 4311 if not Back_End_Inlining 4312 and then (Front_End_Inlining or else Has_Inline_Always) 4313 and then (Is_In_Main_Unit (N) 4314 or else In_Main_Context (Current_Scope)) 4315 and then Nkind (Parent (N)) /= N_Compilation_Unit 4316 then 4317 Inline_Now := True; 4318 4319 -- In configurable_run_time mode we force the inlining of 4320 -- predefined subprograms marked Inline_Always, to minimize 4321 -- the use of the run-time library. 4322 4323 elsif In_Predefined_Unit (Gen_Decl) 4324 and then Configurable_Run_Time_Mode 4325 and then Nkind (Parent (N)) /= N_Compilation_Unit 4326 then 4327 Inline_Now := True; 4328 end if; 4329 4330 -- If the current scope is itself an instance within a child 4331 -- unit, there will be duplications in the scope stack, and the 4332 -- unstacking mechanism in Inline_Instance_Body will fail. 4333 -- This loses some rare cases of optimization, and might be 4334 -- improved some day, if we can find a proper abstraction for 4335 -- "the complete compilation context" that can be saved and 4336 -- restored. ??? 4337 4338 if Is_Generic_Instance (Current_Scope) then 4339 declare 4340 Curr_Unit : constant Entity_Id := 4341 Cunit_Entity (Current_Sem_Unit); 4342 begin 4343 if Curr_Unit /= Current_Scope 4344 and then Is_Child_Unit (Curr_Unit) 4345 then 4346 Inline_Now := False; 4347 end if; 4348 end; 4349 end if; 4350 end if; 4351 4352 Needs_Body := 4353 (Unit_Requires_Body (Gen_Unit) 4354 or else Enclosing_Body_Present 4355 or else Present (Corresponding_Body (Gen_Decl))) 4356 and then (Is_In_Main_Unit (N) 4357 or else Might_Inline_Subp (Gen_Unit)) 4358 and then not Is_Actual_Pack 4359 and then not Inline_Now 4360 and then (Operating_Mode = Generate_Code 4361 4362 -- Need comment for this check ??? 4363 4364 or else (Operating_Mode = Check_Semantics 4365 and then (ASIS_Mode or GNATprove_Mode))); 4366 4367 -- If front-end inlining is enabled or there are any subprograms 4368 -- marked with Inline_Always, do not instantiate body when within 4369 -- a generic context. 4370 4371 if ((Front_End_Inlining or else Has_Inline_Always) 4372 and then not Expander_Active) 4373 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 4374 then 4375 Needs_Body := False; 4376 end if; 4377 4378 -- If the current context is generic, and the package being 4379 -- instantiated is declared within a formal package, there is no 4380 -- body to instantiate until the enclosing generic is instantiated 4381 -- and there is an actual for the formal package. If the formal 4382 -- package has parameters, we build a regular package instance for 4383 -- it, that precedes the original formal package declaration. 4384 4385 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 4386 declare 4387 Decl : constant Node_Id := 4388 Original_Node 4389 (Unit_Declaration_Node (Scope (Gen_Unit))); 4390 begin 4391 if Nkind (Decl) = N_Formal_Package_Declaration 4392 or else (Nkind (Decl) = N_Package_Declaration 4393 and then Is_List_Member (Decl) 4394 and then Present (Next (Decl)) 4395 and then 4396 Nkind (Next (Decl)) = 4397 N_Formal_Package_Declaration) 4398 then 4399 Needs_Body := False; 4400 end if; 4401 end; 4402 end if; 4403 end; 4404 4405 -- For RCI unit calling stubs, we omit the instance body if the 4406 -- instance is the RCI library unit itself. 4407 4408 -- However there is a special case for nested instances: in this case 4409 -- we do generate the instance body, as it might be required, e.g. 4410 -- because it provides stream attributes for some type used in the 4411 -- profile of a remote subprogram. This is consistent with 12.3(12), 4412 -- which indicates that the instance body occurs at the place of the 4413 -- instantiation, and thus is part of the RCI declaration, which is 4414 -- present on all client partitions (this is E.2.3(18)). 4415 4416 -- Note that AI12-0002 may make it illegal at some point to have 4417 -- stream attributes defined in an RCI unit, in which case this 4418 -- special case will become unnecessary. In the meantime, there 4419 -- is known application code in production that depends on this 4420 -- being possible, so we definitely cannot eliminate the body in 4421 -- the case of nested instances for the time being. 4422 4423 -- When we generate a nested instance body, calling stubs for any 4424 -- relevant subprogram will be be inserted immediately after the 4425 -- subprogram declarations, and will take precedence over the 4426 -- subsequent (original) body. (The stub and original body will be 4427 -- complete homographs, but this is permitted in an instance). 4428 -- (Could we do better and remove the original body???) 4429 4430 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 4431 and then Comes_From_Source (N) 4432 and then Nkind (Parent (N)) = N_Compilation_Unit 4433 then 4434 Needs_Body := False; 4435 end if; 4436 4437 if Needs_Body then 4438 4439 -- Here is a defence against a ludicrous number of instantiations 4440 -- caused by a circular set of instantiation attempts. 4441 4442 if Pending_Instantiations.Last > Maximum_Instantiations then 4443 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 4444 Error_Msg_N ("too many instantiations, exceeds max of^", N); 4445 Error_Msg_N ("\limit can be changed using -gnateinn switch", N); 4446 raise Unrecoverable_Error; 4447 end if; 4448 4449 -- Indicate that the enclosing scopes contain an instantiation, 4450 -- and that cleanup actions should be delayed until after the 4451 -- instance body is expanded. 4452 4453 Check_Forward_Instantiation (Gen_Decl); 4454 if Nkind (N) = N_Package_Instantiation then 4455 declare 4456 Enclosing_Master : Entity_Id; 4457 4458 begin 4459 -- Loop to search enclosing masters 4460 4461 Enclosing_Master := Current_Scope; 4462 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 4463 if Ekind (Enclosing_Master) = E_Package then 4464 if Is_Compilation_Unit (Enclosing_Master) then 4465 if In_Package_Body (Enclosing_Master) then 4466 Delay_Descriptors 4467 (Body_Entity (Enclosing_Master)); 4468 else 4469 Delay_Descriptors 4470 (Enclosing_Master); 4471 end if; 4472 4473 exit Scope_Loop; 4474 4475 else 4476 Enclosing_Master := Scope (Enclosing_Master); 4477 end if; 4478 4479 elsif Is_Generic_Unit (Enclosing_Master) 4480 or else Ekind (Enclosing_Master) = E_Void 4481 then 4482 -- Cleanup actions will eventually be performed on the 4483 -- enclosing subprogram or package instance, if any. 4484 -- Enclosing scope is void in the formal part of a 4485 -- generic subprogram. 4486 4487 exit Scope_Loop; 4488 4489 else 4490 if Ekind (Enclosing_Master) = E_Entry 4491 and then 4492 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 4493 then 4494 if not Expander_Active then 4495 exit Scope_Loop; 4496 else 4497 Enclosing_Master := 4498 Protected_Body_Subprogram (Enclosing_Master); 4499 end if; 4500 end if; 4501 4502 Set_Delay_Cleanups (Enclosing_Master); 4503 4504 while Ekind (Enclosing_Master) = E_Block loop 4505 Enclosing_Master := Scope (Enclosing_Master); 4506 end loop; 4507 4508 if Is_Subprogram (Enclosing_Master) then 4509 Delay_Descriptors (Enclosing_Master); 4510 4511 elsif Is_Task_Type (Enclosing_Master) then 4512 declare 4513 TBP : constant Node_Id := 4514 Get_Task_Body_Procedure 4515 (Enclosing_Master); 4516 begin 4517 if Present (TBP) then 4518 Delay_Descriptors (TBP); 4519 Set_Delay_Cleanups (TBP); 4520 end if; 4521 end; 4522 end if; 4523 4524 exit Scope_Loop; 4525 end if; 4526 end loop Scope_Loop; 4527 end; 4528 4529 -- Make entry in table 4530 4531 Add_Pending_Instantiation (N, Act_Decl); 4532 end if; 4533 end if; 4534 4535 Set_Categorization_From_Pragmas (Act_Decl); 4536 4537 if Parent_Installed then 4538 Hide_Current_Scope; 4539 end if; 4540 4541 Set_Instance_Spec (N, Act_Decl); 4542 4543 -- If not a compilation unit, insert the package declaration before 4544 -- the original instantiation node. 4545 4546 if Nkind (Parent (N)) /= N_Compilation_Unit then 4547 Mark_Rewrite_Insertion (Act_Decl); 4548 Insert_Before (N, Act_Decl); 4549 4550 if Has_Aspects (N) then 4551 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4552 4553 -- The pragma created for a Default_Storage_Pool aspect must 4554 -- appear ahead of the declarations in the instance spec. 4555 -- Analysis has placed it after the instance node, so remove 4556 -- it and reinsert it properly now. 4557 4558 declare 4559 ASN : constant Node_Id := First (Aspect_Specifications (N)); 4560 A_Name : constant Name_Id := Chars (Identifier (ASN)); 4561 Decl : Node_Id; 4562 4563 begin 4564 if A_Name = Name_Default_Storage_Pool then 4565 if No (Visible_Declarations (Act_Spec)) then 4566 Set_Visible_Declarations (Act_Spec, New_List); 4567 end if; 4568 4569 Decl := Next (N); 4570 while Present (Decl) loop 4571 if Nkind (Decl) = N_Pragma then 4572 Remove (Decl); 4573 Prepend (Decl, Visible_Declarations (Act_Spec)); 4574 exit; 4575 end if; 4576 4577 Next (Decl); 4578 end loop; 4579 end if; 4580 end; 4581 end if; 4582 4583 Analyze (Act_Decl); 4584 4585 -- For an instantiation that is a compilation unit, place 4586 -- declaration on current node so context is complete for analysis 4587 -- (including nested instantiations). If this is the main unit, 4588 -- the declaration eventually replaces the instantiation node. 4589 -- If the instance body is created later, it replaces the 4590 -- instance node, and the declaration is attached to it 4591 -- (see Build_Instance_Compilation_Unit_Nodes). 4592 4593 else 4594 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 4595 4596 -- The entity for the current unit is the newly created one, 4597 -- and all semantic information is attached to it. 4598 4599 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 4600 4601 -- If this is the main unit, replace the main entity as well 4602 4603 if Current_Sem_Unit = Main_Unit then 4604 Main_Unit_Entity := Act_Decl_Id; 4605 end if; 4606 end if; 4607 4608 Set_Unit (Parent (N), Act_Decl); 4609 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 4610 Set_Package_Instantiation (Act_Decl_Id, N); 4611 4612 -- Process aspect specifications of the instance node, if any, to 4613 -- take into account categorization pragmas before analyzing the 4614 -- instance. 4615 4616 if Has_Aspects (N) then 4617 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4618 end if; 4619 4620 Analyze (Act_Decl); 4621 Set_Unit (Parent (N), N); 4622 Set_Body_Required (Parent (N), False); 4623 4624 -- We never need elaboration checks on instantiations, since by 4625 -- definition, the body instantiation is elaborated at the same 4626 -- time as the spec instantiation. 4627 4628 if Legacy_Elaboration_Checks then 4629 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4630 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4631 end if; 4632 end if; 4633 4634 if Legacy_Elaboration_Checks then 4635 Check_Elab_Instantiation (N); 4636 end if; 4637 4638 -- Save the scenario for later examination by the ABE Processing 4639 -- phase. 4640 4641 Record_Elaboration_Scenario (N); 4642 4643 -- The instantiation results in a guaranteed ABE 4644 4645 if Is_Known_Guaranteed_ABE (N) and then Needs_Body then 4646 4647 -- Do not instantiate the corresponding body because gigi cannot 4648 -- handle certain types of premature instantiations. 4649 4650 Pending_Instantiations.Decrement_Last; 4651 4652 -- Create completing bodies for all subprogram declarations since 4653 -- their real bodies will not be instantiated. 4654 4655 Provide_Completing_Bodies (Instance_Spec (N)); 4656 end if; 4657 4658 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4659 4660 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 4661 First_Private_Entity (Act_Decl_Id)); 4662 4663 -- If the instantiation will receive a body, the unit will be 4664 -- transformed into a package body, and receive its own elaboration 4665 -- entity. Otherwise, the nature of the unit is now a package 4666 -- declaration. 4667 4668 if Nkind (Parent (N)) = N_Compilation_Unit 4669 and then not Needs_Body 4670 then 4671 Rewrite (N, Act_Decl); 4672 end if; 4673 4674 if Present (Corresponding_Body (Gen_Decl)) 4675 or else Unit_Requires_Body (Gen_Unit) 4676 then 4677 Set_Has_Completion (Act_Decl_Id); 4678 end if; 4679 4680 Check_Formal_Packages (Act_Decl_Id); 4681 4682 Restore_Hidden_Primitives (Vis_Prims_List); 4683 Restore_Private_Views (Act_Decl_Id); 4684 4685 Inherit_Context (Gen_Decl, N); 4686 4687 if Parent_Installed then 4688 Remove_Parent; 4689 end if; 4690 4691 Restore_Env; 4692 Env_Installed := False; 4693 end if; 4694 4695 Validate_Categorization_Dependency (N, Act_Decl_Id); 4696 4697 -- There used to be a check here to prevent instantiations in local 4698 -- contexts if the No_Local_Allocators restriction was active. This 4699 -- check was removed by a binding interpretation in AI-95-00130/07, 4700 -- but we retain the code for documentation purposes. 4701 4702 -- if Ekind (Act_Decl_Id) /= E_Void 4703 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4704 -- then 4705 -- Check_Restriction (No_Local_Allocators, N); 4706 -- end if; 4707 4708 if Inline_Now then 4709 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4710 end if; 4711 4712 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4713 -- be used as defining identifiers for a formal package and for the 4714 -- corresponding expanded package. 4715 4716 if Nkind (N) = N_Formal_Package_Declaration then 4717 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4718 Set_Comes_From_Source (Act_Decl_Id, True); 4719 Set_Is_Generic_Instance (Act_Decl_Id, False); 4720 Set_Defining_Identifier (N, Act_Decl_Id); 4721 end if; 4722 4723 -- Check that if N is an instantiation of System.Dim_Float_IO or 4724 -- System.Dim_Integer_IO, the formal type has a dimension system. 4725 4726 if Nkind (N) = N_Package_Instantiation 4727 and then Is_Dim_IO_Package_Instantiation (N) 4728 then 4729 declare 4730 Assoc : constant Node_Id := First (Generic_Associations (N)); 4731 begin 4732 if not Has_Dimension_System 4733 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4734 then 4735 Error_Msg_N ("type with a dimension system expected", Assoc); 4736 end if; 4737 end; 4738 end if; 4739 4740 <<Leave>> 4741 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then 4742 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4743 end if; 4744 4745 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4746 Restore_Ghost_Mode (Saved_GM); 4747 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4748 Style_Check := Saved_Style_Check; 4749 4750 exception 4751 when Instantiation_Error => 4752 if Parent_Installed then 4753 Remove_Parent; 4754 end if; 4755 4756 if Env_Installed then 4757 Restore_Env; 4758 end if; 4759 4760 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4761 Restore_Ghost_Mode (Saved_GM); 4762 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4763 Style_Check := Saved_Style_Check; 4764 end Analyze_Package_Instantiation; 4765 4766 -------------------------- 4767 -- Inline_Instance_Body -- 4768 -------------------------- 4769 4770 -- WARNING: This routine manages SPARK regions. Return statements must be 4771 -- replaced by gotos which jump to the end of the routine and restore the 4772 -- SPARK mode. 4773 4774 procedure Inline_Instance_Body 4775 (N : Node_Id; 4776 Gen_Unit : Entity_Id; 4777 Act_Decl : Node_Id) 4778 is 4779 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4780 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4781 Gen_Comp : constant Entity_Id := 4782 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4783 4784 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 4785 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 4786 -- Save the SPARK mode-related data to restore on exit. Removing 4787 -- enclosing scopes to provide a clean environment for analysis of 4788 -- the inlined body will eliminate any previously set SPARK_Mode. 4789 4790 Scope_Stack_Depth : constant Pos := 4791 Scope_Stack.Last - Scope_Stack.First + 1; 4792 4793 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4794 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4795 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4796 4797 Curr_Scope : Entity_Id := Empty; 4798 List : Elist_Id := No_Elist; -- init to avoid warning 4799 N_Instances : Nat := 0; 4800 Num_Inner : Nat := 0; 4801 Num_Scopes : Nat := 0; 4802 Removed : Boolean := False; 4803 S : Entity_Id; 4804 Vis : Boolean; 4805 4806 begin 4807 -- Case of generic unit defined in another unit. We must remove the 4808 -- complete context of the current unit to install that of the generic. 4809 4810 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4811 4812 -- Add some comments for the following two loops ??? 4813 4814 S := Current_Scope; 4815 while Present (S) and then S /= Standard_Standard loop 4816 loop 4817 Num_Scopes := Num_Scopes + 1; 4818 4819 Use_Clauses (Num_Scopes) := 4820 (Scope_Stack.Table 4821 (Scope_Stack.Last - Num_Scopes + 1). 4822 First_Use_Clause); 4823 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4824 4825 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4826 or else Scope_Stack.Table 4827 (Scope_Stack.Last - Num_Scopes).Entity = Scope (S); 4828 end loop; 4829 4830 exit when Is_Generic_Instance (S) 4831 and then (In_Package_Body (S) 4832 or else Ekind (S) = E_Procedure 4833 or else Ekind (S) = E_Function); 4834 S := Scope (S); 4835 end loop; 4836 4837 Vis := Is_Immediately_Visible (Gen_Comp); 4838 4839 -- Find and save all enclosing instances 4840 4841 S := Current_Scope; 4842 4843 while Present (S) 4844 and then S /= Standard_Standard 4845 loop 4846 if Is_Generic_Instance (S) then 4847 N_Instances := N_Instances + 1; 4848 Instances (N_Instances) := S; 4849 4850 exit when In_Package_Body (S); 4851 end if; 4852 4853 S := Scope (S); 4854 end loop; 4855 4856 -- Remove context of current compilation unit, unless we are within a 4857 -- nested package instantiation, in which case the context has been 4858 -- removed previously. 4859 4860 -- If current scope is the body of a child unit, remove context of 4861 -- spec as well. If an enclosing scope is an instance body, the 4862 -- context has already been removed, but the entities in the body 4863 -- must be made invisible as well. 4864 4865 S := Current_Scope; 4866 while Present (S) and then S /= Standard_Standard loop 4867 if Is_Generic_Instance (S) 4868 and then (In_Package_Body (S) 4869 or else Ekind_In (S, E_Procedure, E_Function)) 4870 then 4871 -- We still have to remove the entities of the enclosing 4872 -- instance from direct visibility. 4873 4874 declare 4875 E : Entity_Id; 4876 begin 4877 E := First_Entity (S); 4878 while Present (E) loop 4879 Set_Is_Immediately_Visible (E, False); 4880 Next_Entity (E); 4881 end loop; 4882 end; 4883 4884 exit; 4885 end if; 4886 4887 if S = Curr_Unit 4888 or else (Ekind (Curr_Unit) = E_Package_Body 4889 and then S = Spec_Entity (Curr_Unit)) 4890 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4891 and then S = Corresponding_Spec 4892 (Unit_Declaration_Node (Curr_Unit))) 4893 then 4894 Removed := True; 4895 4896 -- Remove entities in current scopes from visibility, so that 4897 -- instance body is compiled in a clean environment. 4898 4899 List := Save_Scope_Stack (Handle_Use => False); 4900 4901 if Is_Child_Unit (S) then 4902 4903 -- Remove child unit from stack, as well as inner scopes. 4904 -- Removing the context of a child unit removes parent units 4905 -- as well. 4906 4907 while Current_Scope /= S loop 4908 Num_Inner := Num_Inner + 1; 4909 Inner_Scopes (Num_Inner) := Current_Scope; 4910 Pop_Scope; 4911 end loop; 4912 4913 Pop_Scope; 4914 Remove_Context (Curr_Comp); 4915 Curr_Scope := S; 4916 4917 else 4918 Remove_Context (Curr_Comp); 4919 end if; 4920 4921 if Ekind (Curr_Unit) = E_Package_Body then 4922 Remove_Context (Library_Unit (Curr_Comp)); 4923 end if; 4924 end if; 4925 4926 S := Scope (S); 4927 end loop; 4928 4929 pragma Assert (Num_Inner < Num_Scopes); 4930 4931 -- The inlined package body must be analyzed with the SPARK_Mode of 4932 -- the enclosing context, otherwise the body may cause bogus errors 4933 -- if a configuration SPARK_Mode pragma in in effect. 4934 4935 Push_Scope (Standard_Standard); 4936 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 4937 Instantiate_Package_Body 4938 (Body_Info => 4939 ((Inst_Node => N, 4940 Act_Decl => Act_Decl, 4941 Expander_Status => Expander_Active, 4942 Current_Sem_Unit => Current_Sem_Unit, 4943 Scope_Suppress => Scope_Suppress, 4944 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4945 Version => Ada_Version, 4946 Version_Pragma => Ada_Version_Pragma, 4947 Warnings => Save_Warnings, 4948 SPARK_Mode => Saved_SM, 4949 SPARK_Mode_Pragma => Saved_SMP)), 4950 Inlined_Body => True); 4951 4952 Pop_Scope; 4953 4954 -- Restore context 4955 4956 Set_Is_Immediately_Visible (Gen_Comp, Vis); 4957 4958 -- Reset Generic_Instance flag so that use clauses can be installed 4959 -- in the proper order. (See Use_One_Package for effect of enclosing 4960 -- instances on processing of use clauses). 4961 4962 for J in 1 .. N_Instances loop 4963 Set_Is_Generic_Instance (Instances (J), False); 4964 end loop; 4965 4966 if Removed then 4967 Install_Context (Curr_Comp, Chain => False); 4968 4969 if Present (Curr_Scope) 4970 and then Is_Child_Unit (Curr_Scope) 4971 then 4972 Push_Scope (Curr_Scope); 4973 Set_Is_Immediately_Visible (Curr_Scope); 4974 4975 -- Finally, restore inner scopes as well 4976 4977 for J in reverse 1 .. Num_Inner loop 4978 Push_Scope (Inner_Scopes (J)); 4979 end loop; 4980 end if; 4981 4982 Restore_Scope_Stack (List, Handle_Use => False); 4983 4984 if Present (Curr_Scope) 4985 and then 4986 (In_Private_Part (Curr_Scope) 4987 or else In_Package_Body (Curr_Scope)) 4988 then 4989 -- Install private declaration of ancestor units, which are 4990 -- currently available. Restore_Scope_Stack and Install_Context 4991 -- only install the visible part of parents. 4992 4993 declare 4994 Par : Entity_Id; 4995 begin 4996 Par := Scope (Curr_Scope); 4997 while (Present (Par)) and then Par /= Standard_Standard loop 4998 Install_Private_Declarations (Par); 4999 Par := Scope (Par); 5000 end loop; 5001 end; 5002 end if; 5003 end if; 5004 5005 -- Restore use clauses. For a child unit, use clauses in the parents 5006 -- are restored when installing the context, so only those in inner 5007 -- scopes (and those local to the child unit itself) need to be 5008 -- installed explicitly. 5009 5010 if Is_Child_Unit (Curr_Unit) and then Removed then 5011 for J in reverse 1 .. Num_Inner + 1 loop 5012 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5013 Use_Clauses (J); 5014 Install_Use_Clauses (Use_Clauses (J)); 5015 end loop; 5016 5017 else 5018 for J in reverse 1 .. Num_Scopes loop 5019 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5020 Use_Clauses (J); 5021 Install_Use_Clauses (Use_Clauses (J)); 5022 end loop; 5023 end if; 5024 5025 -- Restore status of instances. If one of them is a body, make its 5026 -- local entities visible again. 5027 5028 declare 5029 E : Entity_Id; 5030 Inst : Entity_Id; 5031 5032 begin 5033 for J in 1 .. N_Instances loop 5034 Inst := Instances (J); 5035 Set_Is_Generic_Instance (Inst, True); 5036 5037 if In_Package_Body (Inst) 5038 or else Ekind_In (S, E_Procedure, E_Function) 5039 then 5040 E := First_Entity (Instances (J)); 5041 while Present (E) loop 5042 Set_Is_Immediately_Visible (E); 5043 Next_Entity (E); 5044 end loop; 5045 end if; 5046 end loop; 5047 end; 5048 5049 -- If generic unit is in current unit, current context is correct. Note 5050 -- that the context is guaranteed to carry the correct SPARK_Mode as no 5051 -- enclosing scopes were removed. 5052 5053 else 5054 Instantiate_Package_Body 5055 (Body_Info => 5056 ((Inst_Node => N, 5057 Act_Decl => Act_Decl, 5058 Expander_Status => Expander_Active, 5059 Current_Sem_Unit => Current_Sem_Unit, 5060 Scope_Suppress => Scope_Suppress, 5061 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 5062 Version => Ada_Version, 5063 Version_Pragma => Ada_Version_Pragma, 5064 Warnings => Save_Warnings, 5065 SPARK_Mode => SPARK_Mode, 5066 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 5067 Inlined_Body => True); 5068 end if; 5069 end Inline_Instance_Body; 5070 5071 ------------------------------------- 5072 -- Analyze_Procedure_Instantiation -- 5073 ------------------------------------- 5074 5075 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 5076 begin 5077 Analyze_Subprogram_Instantiation (N, E_Procedure); 5078 end Analyze_Procedure_Instantiation; 5079 5080 ----------------------------------- 5081 -- Need_Subprogram_Instance_Body -- 5082 ----------------------------------- 5083 5084 function Need_Subprogram_Instance_Body 5085 (N : Node_Id; 5086 Subp : Entity_Id) return Boolean 5087 is 5088 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean; 5089 -- Return True if E is an inlined subprogram, an inlined renaming or a 5090 -- subprogram nested in an inlined subprogram. The inlining machinery 5091 -- totally disregards nested subprograms since it considers that they 5092 -- will always be compiled if the parent is (see Inline.Is_Nested). 5093 5094 ------------------------------------ 5095 -- Is_Inlined_Or_Child_Of_Inlined -- 5096 ------------------------------------ 5097 5098 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is 5099 Scop : Entity_Id; 5100 5101 begin 5102 if Is_Inlined (E) or else Is_Inlined (Alias (E)) then 5103 return True; 5104 end if; 5105 5106 Scop := Scope (E); 5107 while Scop /= Standard_Standard loop 5108 if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then 5109 return True; 5110 end if; 5111 5112 Scop := Scope (Scop); 5113 end loop; 5114 5115 return False; 5116 end Is_Inlined_Or_Child_Of_Inlined; 5117 5118 begin 5119 -- Must be in the main unit or inlined (or child of inlined) 5120 5121 if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) 5122 5123 -- Must be generating code or analyzing code in ASIS/GNATprove mode 5124 5125 and then (Operating_Mode = Generate_Code 5126 or else (Operating_Mode = Check_Semantics 5127 and then (ASIS_Mode or GNATprove_Mode))) 5128 5129 -- The body is needed when generating code (full expansion), in ASIS 5130 -- mode for other tools, and in GNATprove mode (special expansion) for 5131 -- formal verification of the body itself. 5132 5133 and then (Expander_Active or ASIS_Mode or GNATprove_Mode) 5134 5135 -- No point in inlining if ABE is inevitable 5136 5137 and then not Is_Known_Guaranteed_ABE (N) 5138 5139 -- Or if subprogram is eliminated 5140 5141 and then not Is_Eliminated (Subp) 5142 then 5143 Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp)); 5144 return True; 5145 5146 -- Here if not inlined, or we ignore the inlining 5147 5148 else 5149 return False; 5150 end if; 5151 end Need_Subprogram_Instance_Body; 5152 5153 -------------------------------------- 5154 -- Analyze_Subprogram_Instantiation -- 5155 -------------------------------------- 5156 5157 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 5158 -- must be replaced by gotos which jump to the end of the routine in order 5159 -- to restore the Ghost and SPARK modes. 5160 5161 procedure Analyze_Subprogram_Instantiation 5162 (N : Node_Id; 5163 K : Entity_Kind) 5164 is 5165 Loc : constant Source_Ptr := Sloc (N); 5166 Gen_Id : constant Node_Id := Name (N); 5167 Errs : constant Nat := Serious_Errors_Detected; 5168 5169 Anon_Id : constant Entity_Id := 5170 Make_Defining_Identifier (Sloc (Defining_Entity (N)), 5171 Chars => New_External_Name 5172 (Chars (Defining_Entity (N)), 'R')); 5173 5174 Act_Decl_Id : Entity_Id := Empty; -- init to avoid warning 5175 Act_Decl : Node_Id; 5176 Act_Spec : Node_Id; 5177 Act_Tree : Node_Id; 5178 5179 Env_Installed : Boolean := False; 5180 Gen_Unit : Entity_Id; 5181 Gen_Decl : Node_Id; 5182 Pack_Id : Entity_Id; 5183 Parent_Installed : Boolean := False; 5184 5185 Renaming_List : List_Id; 5186 -- The list of declarations that link formals and actuals of the 5187 -- instance. These are subtype declarations for formal types, and 5188 -- renaming declarations for other formals. The subprogram declaration 5189 -- for the instance is then appended to the list, and the last item on 5190 -- the list is the renaming declaration for the instance. 5191 5192 procedure Analyze_Instance_And_Renamings; 5193 -- The instance must be analyzed in a context that includes the mappings 5194 -- of generic parameters into actuals. We create a package declaration 5195 -- for this purpose, and a subprogram with an internal name within the 5196 -- package. The subprogram instance is simply an alias for the internal 5197 -- subprogram, declared in the current scope. 5198 5199 procedure Build_Subprogram_Renaming; 5200 -- If the subprogram is recursive, there are occurrences of the name of 5201 -- the generic within the body, which must resolve to the current 5202 -- instance. We add a renaming declaration after the declaration, which 5203 -- is available in the instance body, as well as in the analysis of 5204 -- aspects that appear in the generic. This renaming declaration is 5205 -- inserted after the instance declaration which it renames. 5206 5207 ------------------------------------ 5208 -- Analyze_Instance_And_Renamings -- 5209 ------------------------------------ 5210 5211 procedure Analyze_Instance_And_Renamings is 5212 Def_Ent : constant Entity_Id := Defining_Entity (N); 5213 Pack_Decl : Node_Id; 5214 5215 begin 5216 if Nkind (Parent (N)) = N_Compilation_Unit then 5217 5218 -- For the case of a compilation unit, the container package has 5219 -- the same name as the instantiation, to insure that the binder 5220 -- calls the elaboration procedure with the right name. Copy the 5221 -- entity of the instance, which may have compilation level flags 5222 -- (e.g. Is_Child_Unit) set. 5223 5224 Pack_Id := New_Copy (Def_Ent); 5225 5226 else 5227 -- Otherwise we use the name of the instantiation concatenated 5228 -- with its source position to ensure uniqueness if there are 5229 -- several instantiations with the same name. 5230 5231 Pack_Id := 5232 Make_Defining_Identifier (Loc, 5233 Chars => New_External_Name 5234 (Related_Id => Chars (Def_Ent), 5235 Suffix => "GP", 5236 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 5237 end if; 5238 5239 Pack_Decl := 5240 Make_Package_Declaration (Loc, 5241 Specification => Make_Package_Specification (Loc, 5242 Defining_Unit_Name => Pack_Id, 5243 Visible_Declarations => Renaming_List, 5244 End_Label => Empty)); 5245 5246 Set_Instance_Spec (N, Pack_Decl); 5247 Set_Is_Generic_Instance (Pack_Id); 5248 Set_Debug_Info_Needed (Pack_Id); 5249 5250 -- Case of not a compilation unit 5251 5252 if Nkind (Parent (N)) /= N_Compilation_Unit then 5253 Mark_Rewrite_Insertion (Pack_Decl); 5254 Insert_Before (N, Pack_Decl); 5255 Set_Has_Completion (Pack_Id); 5256 5257 -- Case of an instantiation that is a compilation unit 5258 5259 -- Place declaration on current node so context is complete for 5260 -- analysis (including nested instantiations), and for use in a 5261 -- context_clause (see Analyze_With_Clause). 5262 5263 else 5264 Set_Unit (Parent (N), Pack_Decl); 5265 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 5266 end if; 5267 5268 Analyze (Pack_Decl); 5269 Check_Formal_Packages (Pack_Id); 5270 Set_Is_Generic_Instance (Pack_Id, False); 5271 5272 -- Why do we clear Is_Generic_Instance??? We set it 20 lines 5273 -- above??? 5274 5275 -- Body of the enclosing package is supplied when instantiating the 5276 -- subprogram body, after semantic analysis is completed. 5277 5278 if Nkind (Parent (N)) = N_Compilation_Unit then 5279 5280 -- Remove package itself from visibility, so it does not 5281 -- conflict with subprogram. 5282 5283 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 5284 5285 -- Set name and scope of internal subprogram so that the proper 5286 -- external name will be generated. The proper scope is the scope 5287 -- of the wrapper package. We need to generate debugging info for 5288 -- the internal subprogram, so set flag accordingly. 5289 5290 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 5291 Set_Scope (Anon_Id, Scope (Pack_Id)); 5292 5293 -- Mark wrapper package as referenced, to avoid spurious warnings 5294 -- if the instantiation appears in various with_ clauses of 5295 -- subunits of the main unit. 5296 5297 Set_Referenced (Pack_Id); 5298 end if; 5299 5300 Set_Is_Generic_Instance (Anon_Id); 5301 Set_Debug_Info_Needed (Anon_Id); 5302 Act_Decl_Id := New_Copy (Anon_Id); 5303 5304 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 5305 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 5306 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 5307 5308 -- Subprogram instance comes from source only if generic does 5309 5310 Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit)); 5311 5312 -- If the instance is a child unit, mark the Id accordingly. Mark 5313 -- the anonymous entity as well, which is the real subprogram and 5314 -- which is used when the instance appears in a context clause. 5315 -- Similarly, propagate the Is_Eliminated flag to handle properly 5316 -- nested eliminated subprograms. 5317 5318 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 5319 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 5320 New_Overloaded_Entity (Act_Decl_Id); 5321 Check_Eliminated (Act_Decl_Id); 5322 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 5323 5324 if Nkind (Parent (N)) = N_Compilation_Unit then 5325 5326 -- In compilation unit case, kill elaboration checks on the 5327 -- instantiation, since they are never needed - the body is 5328 -- instantiated at the same point as the spec. 5329 5330 if Legacy_Elaboration_Checks then 5331 Set_Kill_Elaboration_Checks (Act_Decl_Id); 5332 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 5333 end if; 5334 5335 Set_Is_Compilation_Unit (Anon_Id); 5336 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 5337 end if; 5338 5339 -- The instance is not a freezing point for the new subprogram. 5340 -- The anonymous subprogram may have a freeze node, created for 5341 -- some delayed aspects. This freeze node must not be inherited 5342 -- by the visible subprogram entity. 5343 5344 Set_Is_Frozen (Act_Decl_Id, False); 5345 Set_Freeze_Node (Act_Decl_Id, Empty); 5346 5347 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 5348 Valid_Operator_Definition (Act_Decl_Id); 5349 end if; 5350 5351 Set_Alias (Act_Decl_Id, Anon_Id); 5352 Set_Has_Completion (Act_Decl_Id); 5353 Set_Related_Instance (Pack_Id, Act_Decl_Id); 5354 5355 if Nkind (Parent (N)) = N_Compilation_Unit then 5356 Set_Body_Required (Parent (N), False); 5357 end if; 5358 end Analyze_Instance_And_Renamings; 5359 5360 ------------------------------- 5361 -- Build_Subprogram_Renaming -- 5362 ------------------------------- 5363 5364 procedure Build_Subprogram_Renaming is 5365 Renaming_Decl : Node_Id; 5366 Unit_Renaming : Node_Id; 5367 5368 begin 5369 Unit_Renaming := 5370 Make_Subprogram_Renaming_Declaration (Loc, 5371 Specification => 5372 Copy_Generic_Node 5373 (Specification (Original_Node (Gen_Decl)), 5374 Empty, 5375 Instantiating => True), 5376 Name => New_Occurrence_Of (Anon_Id, Loc)); 5377 5378 -- The generic may be a a child unit. The renaming needs an 5379 -- identifier with the proper name. 5380 5381 Set_Defining_Unit_Name (Specification (Unit_Renaming), 5382 Make_Defining_Identifier (Loc, Chars (Gen_Unit))); 5383 5384 -- If there is a formal subprogram with the same name as the unit 5385 -- itself, do not add this renaming declaration, to prevent 5386 -- ambiguities when there is a call with that name in the body. 5387 -- This is a partial and ugly fix for one ACATS test. ??? 5388 5389 Renaming_Decl := First (Renaming_List); 5390 while Present (Renaming_Decl) loop 5391 if Nkind (Renaming_Decl) = N_Subprogram_Renaming_Declaration 5392 and then 5393 Chars (Defining_Entity (Renaming_Decl)) = Chars (Gen_Unit) 5394 then 5395 exit; 5396 end if; 5397 5398 Next (Renaming_Decl); 5399 end loop; 5400 5401 if No (Renaming_Decl) then 5402 Append (Unit_Renaming, Renaming_List); 5403 end if; 5404 end Build_Subprogram_Renaming; 5405 5406 -- Local variables 5407 5408 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 5409 Saved_ISMP : constant Boolean := 5410 Ignore_SPARK_Mode_Pragmas_In_Instance; 5411 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 5412 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 5413 -- Save the Ghost and SPARK mode-related data to restore on exit 5414 5415 Vis_Prims_List : Elist_Id := No_Elist; 5416 -- List of primitives made temporarily visible in the instantiation 5417 -- to match the visibility of the formal type 5418 5419 -- Start of processing for Analyze_Subprogram_Instantiation 5420 5421 begin 5422 -- Preserve relevant elaboration-related attributes of the context which 5423 -- are no longer available or very expensive to recompute once analysis, 5424 -- resolution, and expansion are over. 5425 5426 Mark_Elaboration_Attributes 5427 (N_Id => N, 5428 Checks => True, 5429 Level => True, 5430 Modes => True, 5431 Warnings => True); 5432 5433 Check_SPARK_05_Restriction ("generic is not allowed", N); 5434 5435 -- Very first thing: check for special Text_IO unit in case we are 5436 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course 5437 -- such an instantiation is bogus (these are packages, not subprograms), 5438 -- but we get a better error message if we do this. 5439 5440 Check_Text_IO_Special_Unit (Gen_Id); 5441 5442 -- Make node global for error reporting 5443 5444 Instantiation_Node := N; 5445 5446 -- For package instantiations we turn off style checks, because they 5447 -- will have been emitted in the generic. For subprogram instantiations 5448 -- we want to apply at least the check on overriding indicators so we 5449 -- do not modify the style check status. 5450 5451 -- The renaming declarations for the actuals do not come from source and 5452 -- will not generate spurious warnings. 5453 5454 Preanalyze_Actuals (N); 5455 5456 Init_Env; 5457 Env_Installed := True; 5458 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 5459 Gen_Unit := Entity (Gen_Id); 5460 5461 -- A subprogram instantiation is Ghost when it is subject to pragma 5462 -- Ghost or the generic template is Ghost. Set the mode now to ensure 5463 -- that any nodes generated during analysis and expansion are marked as 5464 -- Ghost. 5465 5466 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 5467 5468 Generate_Reference (Gen_Unit, Gen_Id); 5469 5470 if Nkind (Gen_Id) = N_Identifier 5471 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 5472 then 5473 Error_Msg_NE 5474 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 5475 end if; 5476 5477 if Etype (Gen_Unit) = Any_Type then 5478 Restore_Env; 5479 goto Leave; 5480 end if; 5481 5482 -- Verify that it is a generic subprogram of the right kind, and that 5483 -- it does not lead to a circular instantiation. 5484 5485 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then 5486 Error_Msg_NE 5487 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); 5488 5489 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then 5490 Error_Msg_NE 5491 ("& is not the name of a generic function", Gen_Id, Gen_Unit); 5492 5493 elsif In_Open_Scopes (Gen_Unit) then 5494 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 5495 5496 else 5497 Set_Entity (Gen_Id, Gen_Unit); 5498 Set_Is_Instantiated (Gen_Unit); 5499 5500 if In_Extended_Main_Source_Unit (N) then 5501 Generate_Reference (Gen_Unit, N); 5502 end if; 5503 5504 -- If renaming, get original unit 5505 5506 if Present (Renamed_Object (Gen_Unit)) 5507 and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, 5508 E_Generic_Function) 5509 then 5510 Gen_Unit := Renamed_Object (Gen_Unit); 5511 Set_Is_Instantiated (Gen_Unit); 5512 Generate_Reference (Gen_Unit, N); 5513 end if; 5514 5515 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 5516 Error_Msg_Node_2 := Current_Scope; 5517 Error_Msg_NE 5518 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 5519 Circularity_Detected := True; 5520 Restore_Hidden_Primitives (Vis_Prims_List); 5521 goto Leave; 5522 end if; 5523 5524 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 5525 5526 -- Initialize renamings map, for error checking 5527 5528 Generic_Renamings.Set_Last (0); 5529 Generic_Renamings_HTable.Reset; 5530 5531 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 5532 5533 -- Copy original generic tree, to produce text for instantiation 5534 5535 Act_Tree := 5536 Copy_Generic_Node 5537 (Original_Node (Gen_Decl), Empty, Instantiating => True); 5538 5539 -- Inherit overriding indicator from instance node 5540 5541 Act_Spec := Specification (Act_Tree); 5542 Set_Must_Override (Act_Spec, Must_Override (N)); 5543 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 5544 5545 Renaming_List := 5546 Analyze_Associations 5547 (I_Node => N, 5548 Formals => Generic_Formal_Declarations (Act_Tree), 5549 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 5550 5551 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 5552 5553 -- The subprogram itself cannot contain a nested instance, so the 5554 -- current parent is left empty. 5555 5556 Set_Instance_Env (Gen_Unit, Empty); 5557 5558 -- Build the subprogram declaration, which does not appear in the 5559 -- generic template, and give it a sloc consistent with that of the 5560 -- template. 5561 5562 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 5563 Set_Generic_Parent (Act_Spec, Gen_Unit); 5564 Act_Decl := 5565 Make_Subprogram_Declaration (Sloc (Act_Spec), 5566 Specification => Act_Spec); 5567 5568 -- The aspects have been copied previously, but they have to be 5569 -- linked explicitly to the new subprogram declaration. Explicit 5570 -- pre/postconditions on the instance are analyzed below, in a 5571 -- separate step. 5572 5573 Move_Aspects (Act_Tree, To => Act_Decl); 5574 Set_Categorization_From_Pragmas (Act_Decl); 5575 5576 if Parent_Installed then 5577 Hide_Current_Scope; 5578 end if; 5579 5580 Append (Act_Decl, Renaming_List); 5581 5582 -- Contract-related source pragmas that follow a generic subprogram 5583 -- must be instantiated explicitly because they are not part of the 5584 -- subprogram template. 5585 5586 Instantiate_Subprogram_Contract 5587 (Original_Node (Gen_Decl), Renaming_List); 5588 5589 Build_Subprogram_Renaming; 5590 5591 -- If the context of the instance is subject to SPARK_Mode "off" or 5592 -- the annotation is altogether missing, set the global flag which 5593 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 5594 -- the instance. This should be done prior to analyzing the instance. 5595 5596 if SPARK_Mode /= On then 5597 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 5598 end if; 5599 5600 -- If the context of an instance is not subject to SPARK_Mode "off", 5601 -- and the generic spec is subject to an explicit SPARK_Mode pragma, 5602 -- the latter should be the one applicable to the instance. 5603 5604 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5605 and then Saved_SM /= Off 5606 and then Present (SPARK_Pragma (Gen_Unit)) 5607 then 5608 Set_SPARK_Mode (Gen_Unit); 5609 end if; 5610 5611 Analyze_Instance_And_Renamings; 5612 5613 -- Restore SPARK_Mode from the context after analysis of the package 5614 -- declaration, so that the SPARK_Mode on the generic spec does not 5615 -- apply to the pending instance for the instance body. 5616 5617 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5618 and then Saved_SM /= Off 5619 and then Present (SPARK_Pragma (Gen_Unit)) 5620 then 5621 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5622 end if; 5623 5624 -- If the generic is marked Import (Intrinsic), then so is the 5625 -- instance. This indicates that there is no body to instantiate. If 5626 -- generic is marked inline, so it the instance, and the anonymous 5627 -- subprogram it renames. If inlined, or else if inlining is enabled 5628 -- for the compilation, we generate the instance body even if it is 5629 -- not within the main unit. 5630 5631 if Is_Intrinsic_Subprogram (Gen_Unit) then 5632 Set_Is_Intrinsic_Subprogram (Anon_Id); 5633 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 5634 5635 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 5636 Validate_Unchecked_Conversion (N, Act_Decl_Id); 5637 end if; 5638 end if; 5639 5640 -- Inherit convention from generic unit. Intrinsic convention, as for 5641 -- an instance of unchecked conversion, is not inherited because an 5642 -- explicit Ada instance has been created. 5643 5644 if Has_Convention_Pragma (Gen_Unit) 5645 and then Convention (Gen_Unit) /= Convention_Intrinsic 5646 then 5647 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 5648 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 5649 end if; 5650 5651 Generate_Definition (Act_Decl_Id); 5652 5653 -- Inherit all inlining-related flags which apply to the generic in 5654 -- the subprogram and its declaration. 5655 5656 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 5657 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 5658 5659 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 5660 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 5661 5662 -- Propagate No_Return if pragma applied to generic unit. This must 5663 -- be done explicitly because pragma does not appear in generic 5664 -- declaration (unlike the aspect case). 5665 5666 if No_Return (Gen_Unit) then 5667 Set_No_Return (Act_Decl_Id); 5668 Set_No_Return (Anon_Id); 5669 end if; 5670 5671 Set_Has_Pragma_Inline_Always 5672 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5673 Set_Has_Pragma_Inline_Always 5674 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5675 5676 -- Mark both the instance spec and the anonymous package in case the 5677 -- body is instantiated at a later pass. This preserves the original 5678 -- context in effect for the body. 5679 5680 if SPARK_Mode /= On then 5681 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 5682 Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); 5683 end if; 5684 5685 if Legacy_Elaboration_Checks 5686 and then not Is_Intrinsic_Subprogram (Gen_Unit) 5687 then 5688 Check_Elab_Instantiation (N); 5689 end if; 5690 5691 -- Save the scenario for later examination by the ABE Processing 5692 -- phase. 5693 5694 Record_Elaboration_Scenario (N); 5695 5696 -- The instantiation results in a guaranteed ABE. Create a completing 5697 -- body for the subprogram declaration because the real body will not 5698 -- be instantiated. 5699 5700 if Is_Known_Guaranteed_ABE (N) then 5701 Provide_Completing_Bodies (Instance_Spec (N)); 5702 end if; 5703 5704 if Is_Dispatching_Operation (Act_Decl_Id) 5705 and then Ada_Version >= Ada_2005 5706 then 5707 declare 5708 Formal : Entity_Id; 5709 5710 begin 5711 Formal := First_Formal (Act_Decl_Id); 5712 while Present (Formal) loop 5713 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 5714 and then Is_Controlling_Formal (Formal) 5715 and then not Can_Never_Be_Null (Formal) 5716 then 5717 Error_Msg_NE 5718 ("access parameter& is controlling,", N, Formal); 5719 Error_Msg_NE 5720 ("\corresponding parameter of & must be explicitly " 5721 & "null-excluding", N, Gen_Id); 5722 end if; 5723 5724 Next_Formal (Formal); 5725 end loop; 5726 end; 5727 end if; 5728 5729 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 5730 5731 Validate_Categorization_Dependency (N, Act_Decl_Id); 5732 5733 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 5734 Inherit_Context (Gen_Decl, N); 5735 5736 Restore_Private_Views (Pack_Id, False); 5737 5738 -- If the context requires a full instantiation, mark node for 5739 -- subsequent construction of the body. 5740 5741 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 5742 Check_Forward_Instantiation (Gen_Decl); 5743 5744 -- The wrapper package is always delayed, because it does not 5745 -- constitute a freeze point, but to insure that the freeze node 5746 -- is placed properly, it is created directly when instantiating 5747 -- the body (otherwise the freeze node might appear to early for 5748 -- nested instantiations). For ASIS purposes, indicate that the 5749 -- wrapper package has replaced the instantiation node. 5750 5751 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5752 Rewrite (N, Unit (Parent (N))); 5753 Set_Unit (Parent (N), N); 5754 end if; 5755 5756 -- Replace instance node for library-level instantiations of 5757 -- intrinsic subprograms, for ASIS use. 5758 5759 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5760 Rewrite (N, Unit (Parent (N))); 5761 Set_Unit (Parent (N), N); 5762 end if; 5763 5764 if Parent_Installed then 5765 Remove_Parent; 5766 end if; 5767 5768 Restore_Hidden_Primitives (Vis_Prims_List); 5769 Restore_Env; 5770 Env_Installed := False; 5771 Generic_Renamings.Set_Last (0); 5772 Generic_Renamings_HTable.Reset; 5773 end if; 5774 5775 <<Leave>> 5776 -- Analyze aspects in declaration if no errors appear in the instance. 5777 5778 if Has_Aspects (N) and then Serious_Errors_Detected = Errs then 5779 Analyze_Aspect_Specifications (N, Act_Decl_Id); 5780 end if; 5781 5782 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5783 Restore_Ghost_Mode (Saved_GM); 5784 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5785 5786 exception 5787 when Instantiation_Error => 5788 if Parent_Installed then 5789 Remove_Parent; 5790 end if; 5791 5792 if Env_Installed then 5793 Restore_Env; 5794 end if; 5795 5796 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5797 Restore_Ghost_Mode (Saved_GM); 5798 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5799 end Analyze_Subprogram_Instantiation; 5800 5801 ------------------------- 5802 -- Get_Associated_Node -- 5803 ------------------------- 5804 5805 function Get_Associated_Node (N : Node_Id) return Node_Id is 5806 Assoc : Node_Id; 5807 5808 begin 5809 Assoc := Associated_Node (N); 5810 5811 if Nkind (Assoc) /= Nkind (N) then 5812 return Assoc; 5813 5814 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 5815 return Assoc; 5816 5817 else 5818 -- If the node is part of an inner generic, it may itself have been 5819 -- remapped into a further generic copy. Associated_Node is otherwise 5820 -- used for the entity of the node, and will be of a different node 5821 -- kind, or else N has been rewritten as a literal or function call. 5822 5823 while Present (Associated_Node (Assoc)) 5824 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 5825 loop 5826 Assoc := Associated_Node (Assoc); 5827 end loop; 5828 5829 -- Follow an additional link in case the final node was rewritten. 5830 -- This can only happen with nested generic units. 5831 5832 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 5833 and then Present (Associated_Node (Assoc)) 5834 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 5835 N_Explicit_Dereference, 5836 N_Integer_Literal, 5837 N_Real_Literal, 5838 N_String_Literal)) 5839 then 5840 Assoc := Associated_Node (Assoc); 5841 end if; 5842 5843 -- An additional special case: an unconstrained type in an object 5844 -- declaration may have been rewritten as a local subtype constrained 5845 -- by the expression in the declaration. We need to recover the 5846 -- original entity, which may be global. 5847 5848 if Present (Original_Node (Assoc)) 5849 and then Nkind (Parent (N)) = N_Object_Declaration 5850 then 5851 Assoc := Original_Node (Assoc); 5852 end if; 5853 5854 return Assoc; 5855 end if; 5856 end Get_Associated_Node; 5857 5858 ---------------------------- 5859 -- Build_Function_Wrapper -- 5860 ---------------------------- 5861 5862 function Build_Function_Wrapper 5863 (Formal_Subp : Entity_Id; 5864 Actual_Subp : Entity_Id) return Node_Id 5865 is 5866 Loc : constant Source_Ptr := Sloc (Current_Scope); 5867 Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); 5868 Actuals : List_Id; 5869 Decl : Node_Id; 5870 Func_Name : Node_Id; 5871 Func : Entity_Id; 5872 Parm_Type : Node_Id; 5873 Profile : List_Id := New_List; 5874 Spec : Node_Id; 5875 Act_F : Entity_Id; 5876 Form_F : Entity_Id; 5877 New_F : Entity_Id; 5878 5879 begin 5880 Func_Name := New_Occurrence_Of (Actual_Subp, Loc); 5881 5882 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5883 Set_Ekind (Func, E_Function); 5884 Set_Is_Generic_Actual_Subprogram (Func); 5885 5886 Actuals := New_List; 5887 Profile := New_List; 5888 5889 Act_F := First_Formal (Actual_Subp); 5890 Form_F := First_Formal (Formal_Subp); 5891 while Present (Form_F) loop 5892 5893 -- Create new formal for profile of wrapper, and add a reference 5894 -- to it in the list of actuals for the enclosing call. The name 5895 -- must be that of the formal in the formal subprogram, because 5896 -- calls to it in the generic body may use named associations. 5897 5898 New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); 5899 5900 Parm_Type := 5901 New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc); 5902 5903 Append_To (Profile, 5904 Make_Parameter_Specification (Loc, 5905 Defining_Identifier => New_F, 5906 Parameter_Type => Parm_Type)); 5907 5908 Append_To (Actuals, New_Occurrence_Of (New_F, Loc)); 5909 Next_Formal (Form_F); 5910 5911 if Present (Act_F) then 5912 Next_Formal (Act_F); 5913 end if; 5914 end loop; 5915 5916 Spec := 5917 Make_Function_Specification (Loc, 5918 Defining_Unit_Name => Func, 5919 Parameter_Specifications => Profile, 5920 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5921 5922 Decl := 5923 Make_Expression_Function (Loc, 5924 Specification => Spec, 5925 Expression => 5926 Make_Function_Call (Loc, 5927 Name => Func_Name, 5928 Parameter_Associations => Actuals)); 5929 5930 return Decl; 5931 end Build_Function_Wrapper; 5932 5933 ---------------------------- 5934 -- Build_Operator_Wrapper -- 5935 ---------------------------- 5936 5937 function Build_Operator_Wrapper 5938 (Formal_Subp : Entity_Id; 5939 Actual_Subp : Entity_Id) return Node_Id 5940 is 5941 Loc : constant Source_Ptr := Sloc (Current_Scope); 5942 Ret_Type : constant Entity_Id := 5943 Get_Instance_Of (Etype (Formal_Subp)); 5944 Op_Type : constant Entity_Id := 5945 Get_Instance_Of (Etype (First_Formal (Formal_Subp))); 5946 Is_Binary : constant Boolean := 5947 Present (Next_Formal (First_Formal (Formal_Subp))); 5948 5949 Decl : Node_Id; 5950 Expr : Node_Id := Empty; 5951 F1, F2 : Entity_Id; 5952 Func : Entity_Id; 5953 Op_Name : Name_Id; 5954 Spec : Node_Id; 5955 L, R : Node_Id; 5956 5957 begin 5958 Op_Name := Chars (Actual_Subp); 5959 5960 -- Create entities for wrapper function and its formals 5961 5962 F1 := Make_Temporary (Loc, 'A'); 5963 F2 := Make_Temporary (Loc, 'B'); 5964 L := New_Occurrence_Of (F1, Loc); 5965 R := New_Occurrence_Of (F2, Loc); 5966 5967 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5968 Set_Ekind (Func, E_Function); 5969 Set_Is_Generic_Actual_Subprogram (Func); 5970 5971 Spec := 5972 Make_Function_Specification (Loc, 5973 Defining_Unit_Name => Func, 5974 Parameter_Specifications => New_List ( 5975 Make_Parameter_Specification (Loc, 5976 Defining_Identifier => F1, 5977 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))), 5978 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5979 5980 if Is_Binary then 5981 Append_To (Parameter_Specifications (Spec), 5982 Make_Parameter_Specification (Loc, 5983 Defining_Identifier => F2, 5984 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))); 5985 end if; 5986 5987 -- Build expression as a function call, or as an operator node 5988 -- that corresponds to the name of the actual, starting with 5989 -- binary operators. 5990 5991 if Op_Name not in Any_Operator_Name then 5992 Expr := 5993 Make_Function_Call (Loc, 5994 Name => 5995 New_Occurrence_Of (Actual_Subp, Loc), 5996 Parameter_Associations => New_List (L)); 5997 5998 if Is_Binary then 5999 Append_To (Parameter_Associations (Expr), R); 6000 end if; 6001 6002 -- Binary operators 6003 6004 elsif Is_Binary then 6005 if Op_Name = Name_Op_And then 6006 Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R); 6007 elsif Op_Name = Name_Op_Or then 6008 Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R); 6009 elsif Op_Name = Name_Op_Xor then 6010 Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R); 6011 elsif Op_Name = Name_Op_Eq then 6012 Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); 6013 elsif Op_Name = Name_Op_Ne then 6014 Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); 6015 elsif Op_Name = Name_Op_Le then 6016 Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R); 6017 elsif Op_Name = Name_Op_Gt then 6018 Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R); 6019 elsif Op_Name = Name_Op_Ge then 6020 Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R); 6021 elsif Op_Name = Name_Op_Lt then 6022 Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R); 6023 elsif Op_Name = Name_Op_Add then 6024 Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R); 6025 elsif Op_Name = Name_Op_Subtract then 6026 Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R); 6027 elsif Op_Name = Name_Op_Concat then 6028 Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R); 6029 elsif Op_Name = Name_Op_Multiply then 6030 Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R); 6031 elsif Op_Name = Name_Op_Divide then 6032 Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R); 6033 elsif Op_Name = Name_Op_Mod then 6034 Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R); 6035 elsif Op_Name = Name_Op_Rem then 6036 Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R); 6037 elsif Op_Name = Name_Op_Expon then 6038 Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R); 6039 end if; 6040 6041 -- Unary operators 6042 6043 else 6044 if Op_Name = Name_Op_Add then 6045 Expr := Make_Op_Plus (Loc, Right_Opnd => L); 6046 elsif Op_Name = Name_Op_Subtract then 6047 Expr := Make_Op_Minus (Loc, Right_Opnd => L); 6048 elsif Op_Name = Name_Op_Abs then 6049 Expr := Make_Op_Abs (Loc, Right_Opnd => L); 6050 elsif Op_Name = Name_Op_Not then 6051 Expr := Make_Op_Not (Loc, Right_Opnd => L); 6052 end if; 6053 end if; 6054 6055 Decl := 6056 Make_Expression_Function (Loc, 6057 Specification => Spec, 6058 Expression => Expr); 6059 6060 return Decl; 6061 end Build_Operator_Wrapper; 6062 6063 ------------------------------------------- 6064 -- Build_Instance_Compilation_Unit_Nodes -- 6065 ------------------------------------------- 6066 6067 procedure Build_Instance_Compilation_Unit_Nodes 6068 (N : Node_Id; 6069 Act_Body : Node_Id; 6070 Act_Decl : Node_Id) 6071 is 6072 Decl_Cunit : Node_Id; 6073 Body_Cunit : Node_Id; 6074 Citem : Node_Id; 6075 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 6076 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 6077 6078 begin 6079 -- A new compilation unit node is built for the instance declaration 6080 6081 Decl_Cunit := 6082 Make_Compilation_Unit (Sloc (N), 6083 Context_Items => Empty_List, 6084 Unit => Act_Decl, 6085 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); 6086 6087 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 6088 6089 -- The new compilation unit is linked to its body, but both share the 6090 -- same file, so we do not set Body_Required on the new unit so as not 6091 -- to create a spurious dependency on a non-existent body in the ali. 6092 -- This simplifies CodePeer unit traversal. 6093 6094 -- We use the original instantiation compilation unit as the resulting 6095 -- compilation unit of the instance, since this is the main unit. 6096 6097 Rewrite (N, Act_Body); 6098 6099 -- Propagate the aspect specifications from the package body template to 6100 -- the instantiated version of the package body. 6101 6102 if Has_Aspects (Act_Body) then 6103 Set_Aspect_Specifications 6104 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body))); 6105 end if; 6106 6107 Body_Cunit := Parent (N); 6108 6109 -- The two compilation unit nodes are linked by the Library_Unit field 6110 6111 Set_Library_Unit (Decl_Cunit, Body_Cunit); 6112 Set_Library_Unit (Body_Cunit, Decl_Cunit); 6113 6114 -- Preserve the private nature of the package if needed 6115 6116 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 6117 6118 -- If the instance is not the main unit, its context, categorization 6119 -- and elaboration entity are not relevant to the compilation. 6120 6121 if Body_Cunit /= Cunit (Main_Unit) then 6122 Make_Instance_Unit (Body_Cunit, In_Main => False); 6123 return; 6124 end if; 6125 6126 -- The context clause items on the instantiation, which are now attached 6127 -- to the body compilation unit (since the body overwrote the original 6128 -- instantiation node), semantically belong on the spec, so copy them 6129 -- there. It's harmless to leave them on the body as well. In fact one 6130 -- could argue that they belong in both places. 6131 6132 Citem := First (Context_Items (Body_Cunit)); 6133 while Present (Citem) loop 6134 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 6135 Next (Citem); 6136 end loop; 6137 6138 -- Propagate categorization flags on packages, so that they appear in 6139 -- the ali file for the spec of the unit. 6140 6141 if Ekind (New_Main) = E_Package then 6142 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 6143 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 6144 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 6145 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 6146 Set_Is_Remote_Call_Interface 6147 (Old_Main, Is_Remote_Call_Interface (New_Main)); 6148 end if; 6149 6150 -- Make entry in Units table, so that binder can generate call to 6151 -- elaboration procedure for body, if any. 6152 6153 Make_Instance_Unit (Body_Cunit, In_Main => True); 6154 Main_Unit_Entity := New_Main; 6155 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 6156 6157 -- Build elaboration entity, since the instance may certainly generate 6158 -- elaboration code requiring a flag for protection. 6159 6160 Build_Elaboration_Entity (Decl_Cunit, New_Main); 6161 end Build_Instance_Compilation_Unit_Nodes; 6162 6163 ----------------------------- 6164 -- Check_Access_Definition -- 6165 ----------------------------- 6166 6167 procedure Check_Access_Definition (N : Node_Id) is 6168 begin 6169 pragma Assert 6170 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); 6171 null; 6172 end Check_Access_Definition; 6173 6174 ----------------------------------- 6175 -- Check_Formal_Package_Instance -- 6176 ----------------------------------- 6177 6178 -- If the formal has specific parameters, they must match those of the 6179 -- actual. Both of them are instances, and the renaming declarations for 6180 -- their formal parameters appear in the same order in both. The analyzed 6181 -- formal has been analyzed in the context of the current instance. 6182 6183 procedure Check_Formal_Package_Instance 6184 (Formal_Pack : Entity_Id; 6185 Actual_Pack : Entity_Id) 6186 is 6187 E1 : Entity_Id := First_Entity (Actual_Pack); 6188 E2 : Entity_Id := First_Entity (Formal_Pack); 6189 Prev_E1 : Entity_Id; 6190 6191 Expr1 : Node_Id; 6192 Expr2 : Node_Id; 6193 6194 procedure Check_Mismatch (B : Boolean); 6195 -- Common error routine for mismatch between the parameters of the 6196 -- actual instance and those of the formal package. 6197 6198 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 6199 -- The formal may come from a nested formal package, and the actual may 6200 -- have been constant-folded. To determine whether the two denote the 6201 -- same entity we may have to traverse several definitions to recover 6202 -- the ultimate entity that they refer to. 6203 6204 function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean; 6205 -- The formal and the actual must be identical, but if both are 6206 -- given by attributes they end up renaming different generated bodies, 6207 -- and we must verify that the attributes themselves match. 6208 6209 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 6210 -- Similarly, if the formal comes from a nested formal package, the 6211 -- actual may designate the formal through multiple renamings, which 6212 -- have to be followed to determine the original variable in question. 6213 6214 -------------------- 6215 -- Check_Mismatch -- 6216 -------------------- 6217 6218 procedure Check_Mismatch (B : Boolean) is 6219 -- A Formal_Type_Declaration for a derived private type is rewritten 6220 -- as a private extension decl. (see Analyze_Formal_Derived_Type), 6221 -- which is why we examine the original node. 6222 6223 Kind : constant Node_Kind := Nkind (Original_Node (Parent (E2))); 6224 6225 begin 6226 if Kind = N_Formal_Type_Declaration then 6227 return; 6228 6229 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 6230 N_Formal_Package_Declaration) 6231 or else Kind in N_Formal_Subprogram_Declaration 6232 then 6233 null; 6234 6235 -- Ada 2012: If both formal and actual are incomplete types they 6236 -- are conformant. 6237 6238 elsif Is_Incomplete_Type (E1) and then Is_Incomplete_Type (E2) then 6239 null; 6240 6241 elsif B then 6242 Error_Msg_NE 6243 ("actual for & in actual instance does not match formal", 6244 Parent (Actual_Pack), E1); 6245 end if; 6246 end Check_Mismatch; 6247 6248 -------------------------------- 6249 -- Same_Instantiated_Constant -- 6250 -------------------------------- 6251 6252 function Same_Instantiated_Constant 6253 (E1, E2 : Entity_Id) return Boolean 6254 is 6255 Ent : Entity_Id; 6256 6257 begin 6258 Ent := E2; 6259 while Present (Ent) loop 6260 if E1 = Ent then 6261 return True; 6262 6263 elsif Ekind (Ent) /= E_Constant then 6264 return False; 6265 6266 elsif Is_Entity_Name (Constant_Value (Ent)) then 6267 if Entity (Constant_Value (Ent)) = E1 then 6268 return True; 6269 else 6270 Ent := Entity (Constant_Value (Ent)); 6271 end if; 6272 6273 -- The actual may be a constant that has been folded. Recover 6274 -- original name. 6275 6276 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 6277 Ent := Entity (Original_Node (Constant_Value (Ent))); 6278 6279 else 6280 return False; 6281 end if; 6282 end loop; 6283 6284 return False; 6285 end Same_Instantiated_Constant; 6286 6287 -------------------------------- 6288 -- Same_Instantiated_Function -- 6289 -------------------------------- 6290 6291 function Same_Instantiated_Function 6292 (E1, E2 : Entity_Id) return Boolean 6293 is 6294 U1, U2 : Node_Id; 6295 begin 6296 if Alias (E1) = Alias (E2) then 6297 return True; 6298 6299 elsif Present (Alias (E2)) then 6300 U1 := Original_Node (Unit_Declaration_Node (E1)); 6301 U2 := Original_Node (Unit_Declaration_Node (Alias (E2))); 6302 6303 return Nkind (U1) = N_Subprogram_Renaming_Declaration 6304 and then Nkind (Name (U1)) = N_Attribute_Reference 6305 6306 and then Nkind (U2) = N_Subprogram_Renaming_Declaration 6307 and then Nkind (Name (U2)) = N_Attribute_Reference 6308 6309 and then 6310 Attribute_Name (Name (U1)) = Attribute_Name (Name (U2)); 6311 else 6312 return False; 6313 end if; 6314 end Same_Instantiated_Function; 6315 6316 -------------------------------- 6317 -- Same_Instantiated_Variable -- 6318 -------------------------------- 6319 6320 function Same_Instantiated_Variable 6321 (E1, E2 : Entity_Id) return Boolean 6322 is 6323 function Original_Entity (E : Entity_Id) return Entity_Id; 6324 -- Follow chain of renamings to the ultimate ancestor 6325 6326 --------------------- 6327 -- Original_Entity -- 6328 --------------------- 6329 6330 function Original_Entity (E : Entity_Id) return Entity_Id is 6331 Orig : Entity_Id; 6332 6333 begin 6334 Orig := E; 6335 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 6336 and then Present (Renamed_Object (Orig)) 6337 and then Is_Entity_Name (Renamed_Object (Orig)) 6338 loop 6339 Orig := Entity (Renamed_Object (Orig)); 6340 end loop; 6341 6342 return Orig; 6343 end Original_Entity; 6344 6345 -- Start of processing for Same_Instantiated_Variable 6346 6347 begin 6348 return Ekind (E1) = Ekind (E2) 6349 and then Original_Entity (E1) = Original_Entity (E2); 6350 end Same_Instantiated_Variable; 6351 6352 -- Start of processing for Check_Formal_Package_Instance 6353 6354 begin 6355 Prev_E1 := E1; 6356 while Present (E1) and then Present (E2) loop 6357 exit when Ekind (E1) = E_Package 6358 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 6359 6360 -- If the formal is the renaming of the formal package, this 6361 -- is the end of its formal part, which may occur before the 6362 -- end of the formal part in the actual in the presence of 6363 -- defaulted parameters in the formal package. 6364 6365 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 6366 and then Renamed_Entity (E2) = Scope (E2); 6367 6368 -- The analysis of the actual may generate additional internal 6369 -- entities. If the formal is defaulted, there is no corresponding 6370 -- analysis and the internal entities must be skipped, until we 6371 -- find corresponding entities again. 6372 6373 if Comes_From_Source (E2) 6374 and then not Comes_From_Source (E1) 6375 and then Chars (E1) /= Chars (E2) 6376 then 6377 while Present (E1) and then Chars (E1) /= Chars (E2) loop 6378 Next_Entity (E1); 6379 end loop; 6380 end if; 6381 6382 if No (E1) then 6383 return; 6384 6385 -- Entities may be declared without full declaration, such as 6386 -- itypes and predefined operators (concatenation for arrays, eg). 6387 -- Skip it and keep the formal entity to find a later match for it. 6388 6389 elsif No (Parent (E2)) and then Ekind (E1) /= Ekind (E2) then 6390 E1 := Prev_E1; 6391 goto Next_E; 6392 6393 -- If the formal entity comes from a formal declaration, it was 6394 -- defaulted in the formal package, and no check is needed on it. 6395 6396 elsif Nkind_In (Original_Node (Parent (E2)), 6397 N_Formal_Object_Declaration, 6398 N_Formal_Type_Declaration) 6399 then 6400 -- If the formal is a tagged type the corresponding class-wide 6401 -- type has been generated as well, and it must be skipped. 6402 6403 if Is_Type (E2) and then Is_Tagged_Type (E2) then 6404 Next_Entity (E2); 6405 end if; 6406 6407 goto Next_E; 6408 6409 -- Ditto for defaulted formal subprograms. 6410 6411 elsif Is_Overloadable (E1) 6412 and then Nkind (Unit_Declaration_Node (E2)) in 6413 N_Formal_Subprogram_Declaration 6414 then 6415 goto Next_E; 6416 6417 elsif Is_Type (E1) then 6418 6419 -- Subtypes must statically match. E1, E2 are the local entities 6420 -- that are subtypes of the actuals. Itypes generated for other 6421 -- parameters need not be checked, the check will be performed 6422 -- on the parameters themselves. 6423 6424 -- If E2 is a formal type declaration, it is a defaulted parameter 6425 -- and needs no checking. 6426 6427 if not Is_Itype (E1) and then not Is_Itype (E2) then 6428 Check_Mismatch 6429 (not Is_Type (E2) 6430 or else Etype (E1) /= Etype (E2) 6431 or else not Subtypes_Statically_Match (E1, E2)); 6432 end if; 6433 6434 elsif Ekind (E1) = E_Constant then 6435 6436 -- IN parameters must denote the same static value, or the same 6437 -- constant, or the literal null. 6438 6439 Expr1 := Expression (Parent (E1)); 6440 6441 if Ekind (E2) /= E_Constant then 6442 Check_Mismatch (True); 6443 goto Next_E; 6444 else 6445 Expr2 := Expression (Parent (E2)); 6446 end if; 6447 6448 if Is_OK_Static_Expression (Expr1) then 6449 if not Is_OK_Static_Expression (Expr2) then 6450 Check_Mismatch (True); 6451 6452 elsif Is_Discrete_Type (Etype (E1)) then 6453 declare 6454 V1 : constant Uint := Expr_Value (Expr1); 6455 V2 : constant Uint := Expr_Value (Expr2); 6456 begin 6457 Check_Mismatch (V1 /= V2); 6458 end; 6459 6460 elsif Is_Real_Type (Etype (E1)) then 6461 declare 6462 V1 : constant Ureal := Expr_Value_R (Expr1); 6463 V2 : constant Ureal := Expr_Value_R (Expr2); 6464 begin 6465 Check_Mismatch (V1 /= V2); 6466 end; 6467 6468 elsif Is_String_Type (Etype (E1)) 6469 and then Nkind (Expr1) = N_String_Literal 6470 then 6471 if Nkind (Expr2) /= N_String_Literal then 6472 Check_Mismatch (True); 6473 else 6474 Check_Mismatch 6475 (not String_Equal (Strval (Expr1), Strval (Expr2))); 6476 end if; 6477 end if; 6478 6479 elsif Is_Entity_Name (Expr1) then 6480 if Is_Entity_Name (Expr2) then 6481 if Entity (Expr1) = Entity (Expr2) then 6482 null; 6483 else 6484 Check_Mismatch 6485 (not Same_Instantiated_Constant 6486 (Entity (Expr1), Entity (Expr2))); 6487 end if; 6488 6489 else 6490 Check_Mismatch (True); 6491 end if; 6492 6493 elsif Is_Entity_Name (Original_Node (Expr1)) 6494 and then Is_Entity_Name (Expr2) 6495 and then Same_Instantiated_Constant 6496 (Entity (Original_Node (Expr1)), Entity (Expr2)) 6497 then 6498 null; 6499 6500 elsif Nkind (Expr1) = N_Null then 6501 Check_Mismatch (Nkind (Expr1) /= N_Null); 6502 6503 else 6504 Check_Mismatch (True); 6505 end if; 6506 6507 elsif Ekind (E1) = E_Variable then 6508 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 6509 6510 elsif Ekind (E1) = E_Package then 6511 Check_Mismatch 6512 (Ekind (E1) /= Ekind (E2) 6513 or else (Present (Renamed_Object (E2)) 6514 and then Renamed_Object (E1) /= 6515 Renamed_Object (E2))); 6516 6517 elsif Is_Overloadable (E1) then 6518 -- Verify that the actual subprograms match. Note that actuals 6519 -- that are attributes are rewritten as subprograms. If the 6520 -- subprogram in the formal package is defaulted, no check is 6521 -- needed. Note that this can only happen in Ada 2005 when the 6522 -- formal package can be partially parameterized. 6523 6524 if Nkind (Unit_Declaration_Node (E1)) = 6525 N_Subprogram_Renaming_Declaration 6526 and then From_Default (Unit_Declaration_Node (E1)) 6527 then 6528 null; 6529 6530 -- If the formal package has an "others" box association that 6531 -- covers this formal, there is no need for a check either. 6532 6533 elsif Nkind (Unit_Declaration_Node (E2)) in 6534 N_Formal_Subprogram_Declaration 6535 and then Box_Present (Unit_Declaration_Node (E2)) 6536 then 6537 null; 6538 6539 -- No check needed if subprogram is a defaulted null procedure 6540 6541 elsif No (Alias (E2)) 6542 and then Ekind (E2) = E_Procedure 6543 and then 6544 Null_Present (Specification (Unit_Declaration_Node (E2))) 6545 then 6546 null; 6547 6548 -- Otherwise the actual in the formal and the actual in the 6549 -- instantiation of the formal must match, up to renamings. 6550 6551 else 6552 Check_Mismatch 6553 (Ekind (E2) /= Ekind (E1) 6554 or else not Same_Instantiated_Function (E1, E2)); 6555 end if; 6556 6557 else 6558 raise Program_Error; 6559 end if; 6560 6561 <<Next_E>> 6562 Prev_E1 := E1; 6563 Next_Entity (E1); 6564 Next_Entity (E2); 6565 end loop; 6566 end Check_Formal_Package_Instance; 6567 6568 --------------------------- 6569 -- Check_Formal_Packages -- 6570 --------------------------- 6571 6572 procedure Check_Formal_Packages (P_Id : Entity_Id) is 6573 E : Entity_Id; 6574 Formal_P : Entity_Id; 6575 Formal_Decl : Node_Id; 6576 6577 begin 6578 -- Iterate through the declarations in the instance, looking for package 6579 -- renaming declarations that denote instances of formal packages. Stop 6580 -- when we find the renaming of the current package itself. The 6581 -- declaration for a formal package without a box is followed by an 6582 -- internal entity that repeats the instantiation. 6583 6584 E := First_Entity (P_Id); 6585 while Present (E) loop 6586 if Ekind (E) = E_Package then 6587 if Renamed_Object (E) = P_Id then 6588 exit; 6589 6590 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6591 null; 6592 6593 else 6594 Formal_Decl := Parent (Associated_Formal_Package (E)); 6595 6596 -- Nothing to check if the formal has a box or an others_clause 6597 -- (necessarily with a box). 6598 6599 if Box_Present (Formal_Decl) then 6600 null; 6601 6602 elsif Nkind (First (Generic_Associations (Formal_Decl))) = 6603 N_Others_Choice 6604 then 6605 -- The internal validating package was generated but formal 6606 -- and instance are known to be compatible. 6607 6608 Formal_P := Next_Entity (E); 6609 Remove (Unit_Declaration_Node (Formal_P)); 6610 6611 else 6612 Formal_P := Next_Entity (E); 6613 6614 -- If the instance is within an enclosing instance body 6615 -- there is no need to verify the legality of current formal 6616 -- packages because they were legal in the generic body. 6617 -- This optimization may be applicable elsewhere, and it 6618 -- also removes spurious errors that may arise with 6619 -- on-the-fly inlining and confusion between private and 6620 -- full views. 6621 6622 if not In_Instance_Body then 6623 Check_Formal_Package_Instance (Formal_P, E); 6624 end if; 6625 6626 -- After checking, remove the internal validating package. 6627 -- It is only needed for semantic checks, and as it may 6628 -- contain generic formal declarations it should not reach 6629 -- gigi. 6630 6631 Remove (Unit_Declaration_Node (Formal_P)); 6632 end if; 6633 end if; 6634 end if; 6635 6636 Next_Entity (E); 6637 end loop; 6638 end Check_Formal_Packages; 6639 6640 --------------------------------- 6641 -- Check_Forward_Instantiation -- 6642 --------------------------------- 6643 6644 procedure Check_Forward_Instantiation (Decl : Node_Id) is 6645 S : Entity_Id; 6646 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 6647 6648 begin 6649 -- The instantiation appears before the generic body if we are in the 6650 -- scope of the unit containing the generic, either in its spec or in 6651 -- the package body, and before the generic body. 6652 6653 if Ekind (Gen_Comp) = E_Package_Body then 6654 Gen_Comp := Spec_Entity (Gen_Comp); 6655 end if; 6656 6657 if In_Open_Scopes (Gen_Comp) 6658 and then No (Corresponding_Body (Decl)) 6659 then 6660 S := Current_Scope; 6661 6662 while Present (S) 6663 and then not Is_Compilation_Unit (S) 6664 and then not Is_Child_Unit (S) 6665 loop 6666 if Ekind (S) = E_Package then 6667 Set_Has_Forward_Instantiation (S); 6668 end if; 6669 6670 S := Scope (S); 6671 end loop; 6672 end if; 6673 end Check_Forward_Instantiation; 6674 6675 --------------------------- 6676 -- Check_Generic_Actuals -- 6677 --------------------------- 6678 6679 -- The visibility of the actuals may be different between the point of 6680 -- generic instantiation and the instantiation of the body. 6681 6682 procedure Check_Generic_Actuals 6683 (Instance : Entity_Id; 6684 Is_Formal_Box : Boolean) 6685 is 6686 E : Entity_Id; 6687 Astype : Entity_Id; 6688 6689 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 6690 -- For a formal that is an array type, the component type is often a 6691 -- previous formal in the same unit. The privacy status of the component 6692 -- type will have been examined earlier in the traversal of the 6693 -- corresponding actuals, and this status should not be modified for 6694 -- the array (sub)type itself. However, if the base type of the array 6695 -- (sub)type is private, its full view must be restored in the body to 6696 -- be consistent with subsequent index subtypes, etc. 6697 -- 6698 -- To detect this case we have to rescan the list of formals, which is 6699 -- usually short enough to ignore the resulting inefficiency. 6700 6701 ----------------------------- 6702 -- Denotes_Previous_Actual -- 6703 ----------------------------- 6704 6705 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 6706 Prev : Entity_Id; 6707 6708 begin 6709 Prev := First_Entity (Instance); 6710 while Present (Prev) loop 6711 if Is_Type (Prev) 6712 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 6713 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 6714 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 6715 then 6716 return True; 6717 6718 elsif Prev = E then 6719 return False; 6720 6721 else 6722 Next_Entity (Prev); 6723 end if; 6724 end loop; 6725 6726 return False; 6727 end Denotes_Previous_Actual; 6728 6729 -- Start of processing for Check_Generic_Actuals 6730 6731 begin 6732 E := First_Entity (Instance); 6733 while Present (E) loop 6734 if Is_Type (E) 6735 and then Nkind (Parent (E)) = N_Subtype_Declaration 6736 and then Scope (Etype (E)) /= Instance 6737 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 6738 then 6739 if Is_Array_Type (E) 6740 and then not Is_Private_Type (Etype (E)) 6741 and then Denotes_Previous_Actual (Component_Type (E)) 6742 then 6743 null; 6744 else 6745 Check_Private_View (Subtype_Indication (Parent (E))); 6746 end if; 6747 6748 Set_Is_Generic_Actual_Type (E, True); 6749 Set_Is_Hidden (E, False); 6750 Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); 6751 6752 -- We constructed the generic actual type as a subtype of the 6753 -- supplied type. This means that it normally would not inherit 6754 -- subtype specific attributes of the actual, which is wrong for 6755 -- the generic case. 6756 6757 Astype := Ancestor_Subtype (E); 6758 6759 if No (Astype) then 6760 6761 -- This can happen when E is an itype that is the full view of 6762 -- a private type completed, e.g. with a constrained array. In 6763 -- that case, use the first subtype, which will carry size 6764 -- information. The base type itself is unconstrained and will 6765 -- not carry it. 6766 6767 Astype := First_Subtype (E); 6768 end if; 6769 6770 Set_Size_Info (E, (Astype)); 6771 Set_RM_Size (E, RM_Size (Astype)); 6772 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 6773 6774 if Is_Discrete_Or_Fixed_Point_Type (E) then 6775 Set_RM_Size (E, RM_Size (Astype)); 6776 6777 -- In nested instances, the base type of an access actual may 6778 -- itself be private, and need to be exchanged. 6779 6780 elsif Is_Access_Type (E) 6781 and then Is_Private_Type (Etype (E)) 6782 then 6783 Check_Private_View 6784 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 6785 end if; 6786 6787 elsif Ekind (E) = E_Package then 6788 6789 -- If this is the renaming for the current instance, we're done. 6790 -- Otherwise it is a formal package. If the corresponding formal 6791 -- was declared with a box, the (instantiations of the) generic 6792 -- formal part are also visible. Otherwise, ignore the entity 6793 -- created to validate the actuals. 6794 6795 if Renamed_Object (E) = Instance then 6796 exit; 6797 6798 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6799 null; 6800 6801 -- The visibility of a formal of an enclosing generic is already 6802 -- correct. 6803 6804 elsif Denotes_Formal_Package (E) then 6805 null; 6806 6807 elsif Present (Associated_Formal_Package (E)) 6808 and then not Is_Generic_Formal (E) 6809 then 6810 if Box_Present (Parent (Associated_Formal_Package (E))) then 6811 Check_Generic_Actuals (Renamed_Object (E), True); 6812 6813 else 6814 Check_Generic_Actuals (Renamed_Object (E), False); 6815 end if; 6816 6817 Set_Is_Hidden (E, False); 6818 end if; 6819 6820 -- If this is a subprogram instance (in a wrapper package) the 6821 -- actual is fully visible. 6822 6823 elsif Is_Wrapper_Package (Instance) then 6824 Set_Is_Hidden (E, False); 6825 6826 -- If the formal package is declared with a box, or if the formal 6827 -- parameter is defaulted, it is visible in the body. 6828 6829 elsif Is_Formal_Box or else Is_Visible_Formal (E) then 6830 Set_Is_Hidden (E, False); 6831 end if; 6832 6833 if Ekind (E) = E_Constant then 6834 6835 -- If the type of the actual is a private type declared in the 6836 -- enclosing scope of the generic unit, the body of the generic 6837 -- sees the full view of the type (because it has to appear in 6838 -- the corresponding package body). If the type is private now, 6839 -- exchange views to restore the proper visiblity in the instance. 6840 6841 declare 6842 Typ : constant Entity_Id := Base_Type (Etype (E)); 6843 -- The type of the actual 6844 6845 Gen_Id : Entity_Id; 6846 -- The generic unit 6847 6848 Parent_Scope : Entity_Id; 6849 -- The enclosing scope of the generic unit 6850 6851 begin 6852 if Is_Wrapper_Package (Instance) then 6853 Gen_Id := 6854 Generic_Parent 6855 (Specification 6856 (Unit_Declaration_Node 6857 (Related_Instance (Instance)))); 6858 else 6859 Gen_Id := 6860 Generic_Parent (Package_Specification (Instance)); 6861 end if; 6862 6863 Parent_Scope := Scope (Gen_Id); 6864 6865 -- The exchange is only needed if the generic is defined 6866 -- within a package which is not a common ancestor of the 6867 -- scope of the instance, and is not already in scope. 6868 6869 if Is_Private_Type (Typ) 6870 and then Scope (Typ) = Parent_Scope 6871 and then Scope (Instance) /= Parent_Scope 6872 and then Ekind (Parent_Scope) = E_Package 6873 and then not Is_Child_Unit (Gen_Id) 6874 then 6875 Switch_View (Typ); 6876 6877 -- If the type of the entity is a subtype, it may also have 6878 -- to be made visible, together with the base type of its 6879 -- full view, after exchange. 6880 6881 if Is_Private_Type (Etype (E)) then 6882 Switch_View (Etype (E)); 6883 Switch_View (Base_Type (Etype (E))); 6884 end if; 6885 end if; 6886 end; 6887 end if; 6888 6889 Next_Entity (E); 6890 end loop; 6891 end Check_Generic_Actuals; 6892 6893 ------------------------------ 6894 -- Check_Generic_Child_Unit -- 6895 ------------------------------ 6896 6897 procedure Check_Generic_Child_Unit 6898 (Gen_Id : Node_Id; 6899 Parent_Installed : in out Boolean) 6900 is 6901 Loc : constant Source_Ptr := Sloc (Gen_Id); 6902 Gen_Par : Entity_Id := Empty; 6903 E : Entity_Id; 6904 Inst_Par : Entity_Id; 6905 S : Node_Id; 6906 6907 function Find_Generic_Child 6908 (Scop : Entity_Id; 6909 Id : Node_Id) return Entity_Id; 6910 -- Search generic parent for possible child unit with the given name 6911 6912 function In_Enclosing_Instance return Boolean; 6913 -- Within an instance of the parent, the child unit may be denoted by 6914 -- a simple name, or an abbreviated expanded name. Examine enclosing 6915 -- scopes to locate a possible parent instantiation. 6916 6917 ------------------------ 6918 -- Find_Generic_Child -- 6919 ------------------------ 6920 6921 function Find_Generic_Child 6922 (Scop : Entity_Id; 6923 Id : Node_Id) return Entity_Id 6924 is 6925 E : Entity_Id; 6926 6927 begin 6928 -- If entity of name is already set, instance has already been 6929 -- resolved, e.g. in an enclosing instantiation. 6930 6931 if Present (Entity (Id)) then 6932 if Scope (Entity (Id)) = Scop then 6933 return Entity (Id); 6934 else 6935 return Empty; 6936 end if; 6937 6938 else 6939 E := First_Entity (Scop); 6940 while Present (E) loop 6941 if Chars (E) = Chars (Id) 6942 and then Is_Child_Unit (E) 6943 then 6944 if Is_Child_Unit (E) 6945 and then not Is_Visible_Lib_Unit (E) 6946 then 6947 Error_Msg_NE 6948 ("generic child unit& is not visible", Gen_Id, E); 6949 end if; 6950 6951 Set_Entity (Id, E); 6952 return E; 6953 end if; 6954 6955 Next_Entity (E); 6956 end loop; 6957 6958 return Empty; 6959 end if; 6960 end Find_Generic_Child; 6961 6962 --------------------------- 6963 -- In_Enclosing_Instance -- 6964 --------------------------- 6965 6966 function In_Enclosing_Instance return Boolean is 6967 Enclosing_Instance : Node_Id; 6968 Instance_Decl : Node_Id; 6969 6970 begin 6971 -- We do not inline any call that contains instantiations, except 6972 -- for instantiations of Unchecked_Conversion, so if we are within 6973 -- an inlined body the current instance does not require parents. 6974 6975 if In_Inlined_Body then 6976 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 6977 return False; 6978 end if; 6979 6980 -- Loop to check enclosing scopes 6981 6982 Enclosing_Instance := Current_Scope; 6983 while Present (Enclosing_Instance) loop 6984 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 6985 6986 if Ekind (Enclosing_Instance) = E_Package 6987 and then Is_Generic_Instance (Enclosing_Instance) 6988 and then Present 6989 (Generic_Parent (Specification (Instance_Decl))) 6990 then 6991 -- Check whether the generic we are looking for is a child of 6992 -- this instance. 6993 6994 E := Find_Generic_Child 6995 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 6996 exit when Present (E); 6997 6998 else 6999 E := Empty; 7000 end if; 7001 7002 Enclosing_Instance := Scope (Enclosing_Instance); 7003 end loop; 7004 7005 if No (E) then 7006 7007 -- Not a child unit 7008 7009 Analyze (Gen_Id); 7010 return False; 7011 7012 else 7013 Rewrite (Gen_Id, 7014 Make_Expanded_Name (Loc, 7015 Chars => Chars (E), 7016 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 7017 Selector_Name => New_Occurrence_Of (E, Loc))); 7018 7019 Set_Entity (Gen_Id, E); 7020 Set_Etype (Gen_Id, Etype (E)); 7021 Parent_Installed := False; -- Already in scope. 7022 return True; 7023 end if; 7024 end In_Enclosing_Instance; 7025 7026 -- Start of processing for Check_Generic_Child_Unit 7027 7028 begin 7029 -- If the name of the generic is given by a selected component, it may 7030 -- be the name of a generic child unit, and the prefix is the name of an 7031 -- instance of the parent, in which case the child unit must be visible. 7032 -- If this instance is not in scope, it must be placed there and removed 7033 -- after instantiation, because what is being instantiated is not the 7034 -- original child, but the corresponding child present in the instance 7035 -- of the parent. 7036 7037 -- If the child is instantiated within the parent, it can be given by 7038 -- a simple name. In this case the instance is already in scope, but 7039 -- the child generic must be recovered from the generic parent as well. 7040 7041 if Nkind (Gen_Id) = N_Selected_Component then 7042 S := Selector_Name (Gen_Id); 7043 Analyze (Prefix (Gen_Id)); 7044 Inst_Par := Entity (Prefix (Gen_Id)); 7045 7046 if Ekind (Inst_Par) = E_Package 7047 and then Present (Renamed_Object (Inst_Par)) 7048 then 7049 Inst_Par := Renamed_Object (Inst_Par); 7050 end if; 7051 7052 if Ekind (Inst_Par) = E_Package then 7053 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 7054 Gen_Par := Generic_Parent (Parent (Inst_Par)); 7055 7056 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 7057 and then 7058 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 7059 then 7060 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 7061 end if; 7062 7063 elsif Ekind (Inst_Par) = E_Generic_Package 7064 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 7065 then 7066 -- A formal package may be a real child package, and not the 7067 -- implicit instance within a parent. In this case the child is 7068 -- not visible and has to be retrieved explicitly as well. 7069 7070 Gen_Par := Inst_Par; 7071 end if; 7072 7073 if Present (Gen_Par) then 7074 7075 -- The prefix denotes an instantiation. The entity itself may be a 7076 -- nested generic, or a child unit. 7077 7078 E := Find_Generic_Child (Gen_Par, S); 7079 7080 if Present (E) then 7081 Change_Selected_Component_To_Expanded_Name (Gen_Id); 7082 Set_Entity (Gen_Id, E); 7083 Set_Etype (Gen_Id, Etype (E)); 7084 Set_Entity (S, E); 7085 Set_Etype (S, Etype (E)); 7086 7087 -- Indicate that this is a reference to the parent 7088 7089 if In_Extended_Main_Source_Unit (Gen_Id) then 7090 Set_Is_Instantiated (Inst_Par); 7091 end if; 7092 7093 -- A common mistake is to replicate the naming scheme of a 7094 -- hierarchy by instantiating a generic child directly, rather 7095 -- than the implicit child in a parent instance: 7096 7097 -- generic .. package Gpar is .. 7098 -- generic .. package Gpar.Child is .. 7099 -- package Par is new Gpar (); 7100 7101 -- with Gpar.Child; 7102 -- package Par.Child is new Gpar.Child (); 7103 -- rather than Par.Child 7104 7105 -- In this case the instantiation is within Par, which is an 7106 -- instance, but Gpar does not denote Par because we are not IN 7107 -- the instance of Gpar, so this is illegal. The test below 7108 -- recognizes this particular case. 7109 7110 if Is_Child_Unit (E) 7111 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 7112 and then (not In_Instance 7113 or else Nkind (Parent (Parent (Gen_Id))) = 7114 N_Compilation_Unit) 7115 then 7116 Error_Msg_N 7117 ("prefix of generic child unit must be instance of parent", 7118 Gen_Id); 7119 end if; 7120 7121 if not In_Open_Scopes (Inst_Par) 7122 and then Nkind (Parent (Gen_Id)) not in 7123 N_Generic_Renaming_Declaration 7124 then 7125 Install_Parent (Inst_Par); 7126 Parent_Installed := True; 7127 7128 elsif In_Open_Scopes (Inst_Par) then 7129 7130 -- If the parent is already installed, install the actuals 7131 -- for its formal packages. This is necessary when the child 7132 -- instance is a child of the parent instance: in this case, 7133 -- the parent is placed on the scope stack but the formal 7134 -- packages are not made visible. 7135 7136 Install_Formal_Packages (Inst_Par); 7137 end if; 7138 7139 else 7140 -- If the generic parent does not contain an entity that 7141 -- corresponds to the selector, the instance doesn't either. 7142 -- Analyzing the node will yield the appropriate error message. 7143 -- If the entity is not a child unit, then it is an inner 7144 -- generic in the parent. 7145 7146 Analyze (Gen_Id); 7147 end if; 7148 7149 else 7150 Analyze (Gen_Id); 7151 7152 if Is_Child_Unit (Entity (Gen_Id)) 7153 and then 7154 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7155 and then not In_Open_Scopes (Inst_Par) 7156 then 7157 Install_Parent (Inst_Par); 7158 Parent_Installed := True; 7159 7160 -- The generic unit may be the renaming of the implicit child 7161 -- present in an instance. In that case the parent instance is 7162 -- obtained from the name of the renamed entity. 7163 7164 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 7165 and then Present (Renamed_Entity (Entity (Gen_Id))) 7166 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 7167 then 7168 declare 7169 Renamed_Package : constant Node_Id := 7170 Name (Parent (Entity (Gen_Id))); 7171 begin 7172 if Nkind (Renamed_Package) = N_Expanded_Name then 7173 Inst_Par := Entity (Prefix (Renamed_Package)); 7174 Install_Parent (Inst_Par); 7175 Parent_Installed := True; 7176 end if; 7177 end; 7178 end if; 7179 end if; 7180 7181 elsif Nkind (Gen_Id) = N_Expanded_Name then 7182 7183 -- Entity already present, analyze prefix, whose meaning may be an 7184 -- instance in the current context. If it is an instance of a 7185 -- relative within another, the proper parent may still have to be 7186 -- installed, if they are not of the same generation. 7187 7188 Analyze (Prefix (Gen_Id)); 7189 7190 -- Prevent cascaded errors 7191 7192 if Etype (Prefix (Gen_Id)) = Any_Type then 7193 return; 7194 end if; 7195 7196 -- In the unlikely case that a local declaration hides the name of 7197 -- the parent package, locate it on the homonym chain. If the context 7198 -- is an instance of the parent, the renaming entity is flagged as 7199 -- such. 7200 7201 Inst_Par := Entity (Prefix (Gen_Id)); 7202 while Present (Inst_Par) 7203 and then not Is_Package_Or_Generic_Package (Inst_Par) 7204 loop 7205 Inst_Par := Homonym (Inst_Par); 7206 end loop; 7207 7208 pragma Assert (Present (Inst_Par)); 7209 Set_Entity (Prefix (Gen_Id), Inst_Par); 7210 7211 if In_Enclosing_Instance then 7212 null; 7213 7214 elsif Present (Entity (Gen_Id)) 7215 and then Is_Child_Unit (Entity (Gen_Id)) 7216 and then not In_Open_Scopes (Inst_Par) 7217 then 7218 Install_Parent (Inst_Par); 7219 Parent_Installed := True; 7220 end if; 7221 7222 elsif In_Enclosing_Instance then 7223 7224 -- The child unit is found in some enclosing scope 7225 7226 null; 7227 7228 else 7229 Analyze (Gen_Id); 7230 7231 -- If this is the renaming of the implicit child in a parent 7232 -- instance, recover the parent name and install it. 7233 7234 if Is_Entity_Name (Gen_Id) then 7235 E := Entity (Gen_Id); 7236 7237 if Is_Generic_Unit (E) 7238 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 7239 and then Is_Child_Unit (Renamed_Object (E)) 7240 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 7241 and then Nkind (Name (Parent (E))) = N_Expanded_Name 7242 then 7243 Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E)))); 7244 Inst_Par := Entity (Prefix (Gen_Id)); 7245 7246 if not In_Open_Scopes (Inst_Par) then 7247 Install_Parent (Inst_Par); 7248 Parent_Installed := True; 7249 end if; 7250 7251 -- If it is a child unit of a non-generic parent, it may be 7252 -- use-visible and given by a direct name. Install parent as 7253 -- for other cases. 7254 7255 elsif Is_Generic_Unit (E) 7256 and then Is_Child_Unit (E) 7257 and then 7258 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7259 and then not Is_Generic_Unit (Scope (E)) 7260 then 7261 if not In_Open_Scopes (Scope (E)) then 7262 Install_Parent (Scope (E)); 7263 Parent_Installed := True; 7264 end if; 7265 end if; 7266 end if; 7267 end if; 7268 end Check_Generic_Child_Unit; 7269 7270 ----------------------------- 7271 -- Check_Hidden_Child_Unit -- 7272 ----------------------------- 7273 7274 procedure Check_Hidden_Child_Unit 7275 (N : Node_Id; 7276 Gen_Unit : Entity_Id; 7277 Act_Decl_Id : Entity_Id) 7278 is 7279 Gen_Id : constant Node_Id := Name (N); 7280 7281 begin 7282 if Is_Child_Unit (Gen_Unit) 7283 and then Is_Child_Unit (Act_Decl_Id) 7284 and then Nkind (Gen_Id) = N_Expanded_Name 7285 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 7286 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 7287 then 7288 Error_Msg_Node_2 := Scope (Act_Decl_Id); 7289 Error_Msg_NE 7290 ("generic unit & is implicitly declared in &", 7291 Defining_Unit_Name (N), Gen_Unit); 7292 Error_Msg_N ("\instance must have different name", 7293 Defining_Unit_Name (N)); 7294 end if; 7295 end Check_Hidden_Child_Unit; 7296 7297 ------------------------ 7298 -- Check_Private_View -- 7299 ------------------------ 7300 7301 procedure Check_Private_View (N : Node_Id) is 7302 T : constant Entity_Id := Etype (N); 7303 BT : Entity_Id; 7304 7305 begin 7306 -- Exchange views if the type was not private in the generic but is 7307 -- private at the point of instantiation. Do not exchange views if 7308 -- the scope of the type is in scope. This can happen if both generic 7309 -- and instance are sibling units, or if type is defined in a parent. 7310 -- In this case the visibility of the type will be correct for all 7311 -- semantic checks. 7312 7313 if Present (T) then 7314 BT := Base_Type (T); 7315 7316 if Is_Private_Type (T) 7317 and then not Has_Private_View (N) 7318 and then Present (Full_View (T)) 7319 and then not In_Open_Scopes (Scope (T)) 7320 then 7321 -- In the generic, the full type was visible. Save the private 7322 -- entity, for subsequent exchange. 7323 7324 Switch_View (T); 7325 7326 elsif Has_Private_View (N) 7327 and then not Is_Private_Type (T) 7328 and then not Has_Been_Exchanged (T) 7329 and then Etype (Get_Associated_Node (N)) /= T 7330 then 7331 -- Only the private declaration was visible in the generic. If 7332 -- the type appears in a subtype declaration, the subtype in the 7333 -- instance must have a view compatible with that of its parent, 7334 -- which must be exchanged (see corresponding code in Restore_ 7335 -- Private_Views). Otherwise, if the type is defined in a parent 7336 -- unit, leave full visibility within instance, which is safe. 7337 7338 if In_Open_Scopes (Scope (Base_Type (T))) 7339 and then not Is_Private_Type (Base_Type (T)) 7340 and then Comes_From_Source (Base_Type (T)) 7341 then 7342 null; 7343 7344 elsif Nkind (Parent (N)) = N_Subtype_Declaration 7345 or else not In_Private_Part (Scope (Base_Type (T))) 7346 then 7347 Prepend_Elmt (T, Exchanged_Views); 7348 Exchange_Declarations (Etype (Get_Associated_Node (N))); 7349 end if; 7350 7351 -- For composite types with inconsistent representation exchange 7352 -- component types accordingly. 7353 7354 elsif Is_Access_Type (T) 7355 and then Is_Private_Type (Designated_Type (T)) 7356 and then not Has_Private_View (N) 7357 and then Present (Full_View (Designated_Type (T))) 7358 then 7359 Switch_View (Designated_Type (T)); 7360 7361 elsif Is_Array_Type (T) then 7362 if Is_Private_Type (Component_Type (T)) 7363 and then not Has_Private_View (N) 7364 and then Present (Full_View (Component_Type (T))) 7365 then 7366 Switch_View (Component_Type (T)); 7367 end if; 7368 7369 -- The normal exchange mechanism relies on the setting of a 7370 -- flag on the reference in the generic. However, an additional 7371 -- mechanism is needed for types that are not explicitly 7372 -- mentioned in the generic, but may be needed in expanded code 7373 -- in the instance. This includes component types of arrays and 7374 -- designated types of access types. This processing must also 7375 -- include the index types of arrays which we take care of here. 7376 7377 declare 7378 Indx : Node_Id; 7379 Typ : Entity_Id; 7380 7381 begin 7382 Indx := First_Index (T); 7383 while Present (Indx) loop 7384 Typ := Base_Type (Etype (Indx)); 7385 7386 if Is_Private_Type (Typ) 7387 and then Present (Full_View (Typ)) 7388 then 7389 Switch_View (Typ); 7390 end if; 7391 7392 Next_Index (Indx); 7393 end loop; 7394 end; 7395 7396 elsif Is_Private_Type (T) 7397 and then Present (Full_View (T)) 7398 and then Is_Array_Type (Full_View (T)) 7399 and then Is_Private_Type (Component_Type (Full_View (T))) 7400 then 7401 Switch_View (T); 7402 7403 -- Finally, a non-private subtype may have a private base type, which 7404 -- must be exchanged for consistency. This can happen when a package 7405 -- body is instantiated, when the scope stack is empty but in fact 7406 -- the subtype and the base type are declared in an enclosing scope. 7407 7408 -- Note that in this case we introduce an inconsistency in the view 7409 -- set, because we switch the base type BT, but there could be some 7410 -- private dependent subtypes of BT which remain unswitched. Such 7411 -- subtypes might need to be switched at a later point (see specific 7412 -- provision for that case in Switch_View). 7413 7414 elsif not Is_Private_Type (T) 7415 and then not Has_Private_View (N) 7416 and then Is_Private_Type (BT) 7417 and then Present (Full_View (BT)) 7418 and then not Is_Generic_Type (BT) 7419 and then not In_Open_Scopes (BT) 7420 then 7421 Prepend_Elmt (Full_View (BT), Exchanged_Views); 7422 Exchange_Declarations (BT); 7423 end if; 7424 end if; 7425 end Check_Private_View; 7426 7427 ----------------------------- 7428 -- Check_Hidden_Primitives -- 7429 ----------------------------- 7430 7431 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 7432 Actual : Node_Id; 7433 Gen_T : Entity_Id; 7434 Result : Elist_Id := No_Elist; 7435 7436 begin 7437 if No (Assoc_List) then 7438 return No_Elist; 7439 end if; 7440 7441 -- Traverse the list of associations between formals and actuals 7442 -- searching for renamings of tagged types 7443 7444 Actual := First (Assoc_List); 7445 while Present (Actual) loop 7446 if Nkind (Actual) = N_Subtype_Declaration then 7447 Gen_T := Generic_Parent_Type (Actual); 7448 7449 if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then 7450 7451 -- Traverse the list of primitives of the actual types 7452 -- searching for hidden primitives that are visible in the 7453 -- corresponding generic formal; leave them visible and 7454 -- append them to Result to restore their decoration later. 7455 7456 Install_Hidden_Primitives 7457 (Prims_List => Result, 7458 Gen_T => Gen_T, 7459 Act_T => Entity (Subtype_Indication (Actual))); 7460 end if; 7461 end if; 7462 7463 Next (Actual); 7464 end loop; 7465 7466 return Result; 7467 end Check_Hidden_Primitives; 7468 7469 -------------------------- 7470 -- Contains_Instance_Of -- 7471 -------------------------- 7472 7473 function Contains_Instance_Of 7474 (Inner : Entity_Id; 7475 Outer : Entity_Id; 7476 N : Node_Id) return Boolean 7477 is 7478 Elmt : Elmt_Id; 7479 Scop : Entity_Id; 7480 7481 begin 7482 Scop := Outer; 7483 7484 -- Verify that there are no circular instantiations. We check whether 7485 -- the unit contains an instance of the current scope or some enclosing 7486 -- scope (in case one of the instances appears in a subunit). Longer 7487 -- circularities involving subunits might seem too pathological to 7488 -- consider, but they were not too pathological for the authors of 7489 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 7490 -- enclosing generic scopes as containing an instance. 7491 7492 loop 7493 -- Within a generic subprogram body, the scope is not generic, to 7494 -- allow for recursive subprograms. Use the declaration to determine 7495 -- whether this is a generic unit. 7496 7497 if Ekind (Scop) = E_Generic_Package 7498 or else (Is_Subprogram (Scop) 7499 and then Nkind (Unit_Declaration_Node (Scop)) = 7500 N_Generic_Subprogram_Declaration) 7501 then 7502 Elmt := First_Elmt (Inner_Instances (Inner)); 7503 7504 while Present (Elmt) loop 7505 if Node (Elmt) = Scop then 7506 Error_Msg_Node_2 := Inner; 7507 Error_Msg_NE 7508 ("circular Instantiation: & instantiated within &!", 7509 N, Scop); 7510 return True; 7511 7512 elsif Node (Elmt) = Inner then 7513 return True; 7514 7515 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 7516 Error_Msg_Node_2 := Inner; 7517 Error_Msg_NE 7518 ("circular Instantiation: & instantiated within &!", 7519 N, Node (Elmt)); 7520 return True; 7521 end if; 7522 7523 Next_Elmt (Elmt); 7524 end loop; 7525 7526 -- Indicate that Inner is being instantiated within Scop 7527 7528 Append_Elmt (Inner, Inner_Instances (Scop)); 7529 end if; 7530 7531 if Scop = Standard_Standard then 7532 exit; 7533 else 7534 Scop := Scope (Scop); 7535 end if; 7536 end loop; 7537 7538 return False; 7539 end Contains_Instance_Of; 7540 7541 ----------------------- 7542 -- Copy_Generic_Node -- 7543 ----------------------- 7544 7545 function Copy_Generic_Node 7546 (N : Node_Id; 7547 Parent_Id : Node_Id; 7548 Instantiating : Boolean) return Node_Id 7549 is 7550 Ent : Entity_Id; 7551 New_N : Node_Id; 7552 7553 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 7554 -- Check the given value of one of the Fields referenced by the current 7555 -- node to determine whether to copy it recursively. The field may hold 7556 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, 7557 -- Char) in which case it need not be copied. 7558 7559 procedure Copy_Descendants; 7560 -- Common utility for various nodes 7561 7562 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 7563 -- Make copy of element list 7564 7565 function Copy_Generic_List 7566 (L : List_Id; 7567 Parent_Id : Node_Id) return List_Id; 7568 -- Apply Copy_Node recursively to the members of a node list 7569 7570 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 7571 -- True if an identifier is part of the defining program unit name of 7572 -- a child unit. The entity of such an identifier must be kept (for 7573 -- ASIS use) even though as the name of an enclosing generic it would 7574 -- otherwise not be preserved in the generic tree. 7575 7576 ---------------------- 7577 -- Copy_Descendants -- 7578 ---------------------- 7579 7580 procedure Copy_Descendants is 7581 use Atree.Unchecked_Access; 7582 -- This code section is part of the implementation of an untyped 7583 -- tree traversal, so it needs direct access to node fields. 7584 7585 begin 7586 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 7587 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 7588 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 7589 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 7590 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 7591 end Copy_Descendants; 7592 7593 ----------------------------- 7594 -- Copy_Generic_Descendant -- 7595 ----------------------------- 7596 7597 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 7598 begin 7599 if D = Union_Id (Empty) then 7600 return D; 7601 7602 elsif D in Node_Range then 7603 return Union_Id 7604 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 7605 7606 elsif D in List_Range then 7607 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 7608 7609 elsif D in Elist_Range then 7610 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 7611 7612 -- Nothing else is copyable (e.g. Uint values), return as is 7613 7614 else 7615 return D; 7616 end if; 7617 end Copy_Generic_Descendant; 7618 7619 ------------------------ 7620 -- Copy_Generic_Elist -- 7621 ------------------------ 7622 7623 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 7624 M : Elmt_Id; 7625 L : Elist_Id; 7626 7627 begin 7628 if Present (E) then 7629 L := New_Elmt_List; 7630 M := First_Elmt (E); 7631 while Present (M) loop 7632 Append_Elmt 7633 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 7634 Next_Elmt (M); 7635 end loop; 7636 7637 return L; 7638 7639 else 7640 return No_Elist; 7641 end if; 7642 end Copy_Generic_Elist; 7643 7644 ----------------------- 7645 -- Copy_Generic_List -- 7646 ----------------------- 7647 7648 function Copy_Generic_List 7649 (L : List_Id; 7650 Parent_Id : Node_Id) return List_Id 7651 is 7652 N : Node_Id; 7653 New_L : List_Id; 7654 7655 begin 7656 if Present (L) then 7657 New_L := New_List; 7658 Set_Parent (New_L, Parent_Id); 7659 7660 N := First (L); 7661 while Present (N) loop 7662 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 7663 Next (N); 7664 end loop; 7665 7666 return New_L; 7667 7668 else 7669 return No_List; 7670 end if; 7671 end Copy_Generic_List; 7672 7673 --------------------------- 7674 -- In_Defining_Unit_Name -- 7675 --------------------------- 7676 7677 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 7678 begin 7679 return 7680 Present (Parent (Nam)) 7681 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 7682 or else 7683 (Nkind (Parent (Nam)) = N_Expanded_Name 7684 and then In_Defining_Unit_Name (Parent (Nam)))); 7685 end In_Defining_Unit_Name; 7686 7687 -- Start of processing for Copy_Generic_Node 7688 7689 begin 7690 if N = Empty then 7691 return N; 7692 end if; 7693 7694 New_N := New_Copy (N); 7695 7696 -- Copy aspects if present 7697 7698 if Has_Aspects (N) then 7699 Set_Has_Aspects (New_N, False); 7700 Set_Aspect_Specifications 7701 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 7702 end if; 7703 7704 -- If we are instantiating, we want to adjust the sloc based on the 7705 -- current S_Adjustment. However, if this is the root node of a subunit, 7706 -- we need to defer that adjustment to below (see "elsif Instantiating 7707 -- and Was_Stub"), so it comes after Create_Instantiation_Source has 7708 -- computed the adjustment. 7709 7710 if Instantiating 7711 and then not (Nkind (N) in N_Proper_Body 7712 and then Was_Originally_Stub (N)) 7713 then 7714 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 7715 end if; 7716 7717 if not Is_List_Member (N) then 7718 Set_Parent (New_N, Parent_Id); 7719 end if; 7720 7721 -- Special casing for identifiers and other entity names and operators 7722 7723 if Nkind_In (New_N, N_Character_Literal, 7724 N_Expanded_Name, 7725 N_Identifier, 7726 N_Operator_Symbol) 7727 or else Nkind (New_N) in N_Op 7728 then 7729 if not Instantiating then 7730 7731 -- Link both nodes in order to assign subsequently the entity of 7732 -- the copy to the original node, in case this is a global 7733 -- reference. 7734 7735 Set_Associated_Node (N, New_N); 7736 7737 -- If we are within an instantiation, this is a nested generic 7738 -- that has already been analyzed at the point of definition. 7739 -- We must preserve references that were global to the enclosing 7740 -- parent at that point. Other occurrences, whether global or 7741 -- local to the current generic, must be resolved anew, so we 7742 -- reset the entity in the generic copy. A global reference has a 7743 -- smaller depth than the parent, or else the same depth in case 7744 -- both are distinct compilation units. 7745 7746 -- A child unit is implicitly declared within the enclosing parent 7747 -- but is in fact global to it, and must be preserved. 7748 7749 -- It is also possible for Current_Instantiated_Parent to be 7750 -- defined, and for this not to be a nested generic, namely if 7751 -- the unit is loaded through Rtsfind. In that case, the entity of 7752 -- New_N is only a link to the associated node, and not a defining 7753 -- occurrence. 7754 7755 -- The entities for parent units in the defining_program_unit of a 7756 -- generic child unit are established when the context of the unit 7757 -- is first analyzed, before the generic copy is made. They are 7758 -- preserved in the copy for use in ASIS queries. 7759 7760 Ent := Entity (New_N); 7761 7762 if No (Current_Instantiated_Parent.Gen_Id) then 7763 if No (Ent) 7764 or else Nkind (Ent) /= N_Defining_Identifier 7765 or else not In_Defining_Unit_Name (N) 7766 then 7767 Set_Associated_Node (New_N, Empty); 7768 end if; 7769 7770 elsif No (Ent) 7771 or else 7772 not Nkind_In (Ent, N_Defining_Identifier, 7773 N_Defining_Character_Literal, 7774 N_Defining_Operator_Symbol) 7775 or else No (Scope (Ent)) 7776 or else 7777 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 7778 and then not Is_Child_Unit (Ent)) 7779 or else 7780 (Scope_Depth (Scope (Ent)) > 7781 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 7782 and then 7783 Get_Source_Unit (Ent) = 7784 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 7785 then 7786 Set_Associated_Node (New_N, Empty); 7787 end if; 7788 7789 -- Case of instantiating identifier or some other name or operator 7790 7791 else 7792 -- If the associated node is still defined, the entity in it 7793 -- is global, and must be copied to the instance. If this copy 7794 -- is being made for a body to inline, it is applied to an 7795 -- instantiated tree, and the entity is already present and 7796 -- must be also preserved. 7797 7798 declare 7799 Assoc : constant Node_Id := Get_Associated_Node (N); 7800 7801 begin 7802 if Present (Assoc) then 7803 if Nkind (Assoc) = Nkind (N) then 7804 Set_Entity (New_N, Entity (Assoc)); 7805 Check_Private_View (N); 7806 7807 -- The node is a reference to a global type and acts as the 7808 -- subtype mark of a qualified expression created in order 7809 -- to aid resolution of accidental overloading in instances. 7810 -- Since N is a reference to a type, the Associated_Node of 7811 -- N denotes an entity rather than another identifier. See 7812 -- Qualify_Universal_Operands for details. 7813 7814 elsif Nkind (N) = N_Identifier 7815 and then Nkind (Parent (N)) = N_Qualified_Expression 7816 and then Subtype_Mark (Parent (N)) = N 7817 and then Is_Qualified_Universal_Literal (Parent (N)) 7818 then 7819 Set_Entity (New_N, Assoc); 7820 7821 -- The name in the call may be a selected component if the 7822 -- call has not been analyzed yet, as may be the case for 7823 -- pre/post conditions in a generic unit. 7824 7825 elsif Nkind (Assoc) = N_Function_Call 7826 and then Is_Entity_Name (Name (Assoc)) 7827 then 7828 Set_Entity (New_N, Entity (Name (Assoc))); 7829 7830 elsif Nkind_In (Assoc, N_Defining_Identifier, 7831 N_Defining_Character_Literal, 7832 N_Defining_Operator_Symbol) 7833 and then Expander_Active 7834 then 7835 -- Inlining case: we are copying a tree that contains 7836 -- global entities, which are preserved in the copy to be 7837 -- used for subsequent inlining. 7838 7839 null; 7840 7841 else 7842 Set_Entity (New_N, Empty); 7843 end if; 7844 end if; 7845 end; 7846 end if; 7847 7848 -- For expanded name, we must copy the Prefix and Selector_Name 7849 7850 if Nkind (N) = N_Expanded_Name then 7851 Set_Prefix 7852 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 7853 7854 Set_Selector_Name (New_N, 7855 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 7856 7857 -- For operators, copy the operands 7858 7859 elsif Nkind (N) in N_Op then 7860 if Nkind (N) in N_Binary_Op then 7861 Set_Left_Opnd (New_N, 7862 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 7863 end if; 7864 7865 Set_Right_Opnd (New_N, 7866 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 7867 end if; 7868 7869 -- Establish a link between an entity from the generic template and the 7870 -- corresponding entity in the generic copy to be analyzed. 7871 7872 elsif Nkind (N) in N_Entity then 7873 if not Instantiating then 7874 Set_Associated_Entity (N, New_N); 7875 end if; 7876 7877 -- Clear any existing link the copy may inherit from the replicated 7878 -- generic template entity. 7879 7880 Set_Associated_Entity (New_N, Empty); 7881 7882 -- Special casing for stubs 7883 7884 elsif Nkind (N) in N_Body_Stub then 7885 7886 -- In any case, we must copy the specification or defining 7887 -- identifier as appropriate. 7888 7889 if Nkind (N) = N_Subprogram_Body_Stub then 7890 Set_Specification (New_N, 7891 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 7892 7893 else 7894 Set_Defining_Identifier (New_N, 7895 Copy_Generic_Node 7896 (Defining_Identifier (N), New_N, Instantiating)); 7897 end if; 7898 7899 -- If we are not instantiating, then this is where we load and 7900 -- analyze subunits, i.e. at the point where the stub occurs. A 7901 -- more permissive system might defer this analysis to the point 7902 -- of instantiation, but this seems too complicated for now. 7903 7904 if not Instantiating then 7905 declare 7906 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 7907 Subunit : Node_Id; 7908 Unum : Unit_Number_Type; 7909 New_Body : Node_Id; 7910 7911 begin 7912 -- Make sure that, if it is a subunit of the main unit that is 7913 -- preprocessed and if -gnateG is specified, the preprocessed 7914 -- file will be written. 7915 7916 Lib.Analysing_Subunit_Of_Main := 7917 Lib.In_Extended_Main_Source_Unit (N); 7918 Unum := 7919 Load_Unit 7920 (Load_Name => Subunit_Name, 7921 Required => False, 7922 Subunit => True, 7923 Error_Node => N); 7924 Lib.Analysing_Subunit_Of_Main := False; 7925 7926 -- If the proper body is not found, a warning message will be 7927 -- emitted when analyzing the stub, or later at the point of 7928 -- instantiation. Here we just leave the stub as is. 7929 7930 if Unum = No_Unit then 7931 Subunits_Missing := True; 7932 goto Subunit_Not_Found; 7933 end if; 7934 7935 Subunit := Cunit (Unum); 7936 7937 if Nkind (Unit (Subunit)) /= N_Subunit then 7938 Error_Msg_N 7939 ("found child unit instead of expected SEPARATE subunit", 7940 Subunit); 7941 Error_Msg_Sloc := Sloc (N); 7942 Error_Msg_N ("\to complete stub #", Subunit); 7943 goto Subunit_Not_Found; 7944 end if; 7945 7946 -- We must create a generic copy of the subunit, in order to 7947 -- perform semantic analysis on it, and we must replace the 7948 -- stub in the original generic unit with the subunit, in order 7949 -- to preserve non-local references within. 7950 7951 -- Only the proper body needs to be copied. Library_Unit and 7952 -- context clause are simply inherited by the generic copy. 7953 -- Note that the copy (which may be recursive if there are 7954 -- nested subunits) must be done first, before attaching it to 7955 -- the enclosing generic. 7956 7957 New_Body := 7958 Copy_Generic_Node 7959 (Proper_Body (Unit (Subunit)), 7960 Empty, Instantiating => False); 7961 7962 -- Now place the original proper body in the original generic 7963 -- unit. This is a body, not a compilation unit. 7964 7965 Rewrite (N, Proper_Body (Unit (Subunit))); 7966 Set_Is_Compilation_Unit (Defining_Entity (N), False); 7967 Set_Was_Originally_Stub (N); 7968 7969 -- Finally replace the body of the subunit with its copy, and 7970 -- make this new subunit into the library unit of the generic 7971 -- copy, which does not have stubs any longer. 7972 7973 Set_Proper_Body (Unit (Subunit), New_Body); 7974 Set_Library_Unit (New_N, Subunit); 7975 Inherit_Context (Unit (Subunit), N); 7976 end; 7977 7978 -- If we are instantiating, this must be an error case, since 7979 -- otherwise we would have replaced the stub node by the proper body 7980 -- that corresponds. So just ignore it in the copy (i.e. we have 7981 -- copied it, and that is good enough). 7982 7983 else 7984 null; 7985 end if; 7986 7987 <<Subunit_Not_Found>> null; 7988 7989 -- If the node is a compilation unit, it is the subunit of a stub, which 7990 -- has been loaded already (see code below). In this case, the library 7991 -- unit field of N points to the parent unit (which is a compilation 7992 -- unit) and need not (and cannot) be copied. 7993 7994 -- When the proper body of the stub is analyzed, the library_unit link 7995 -- is used to establish the proper context (see sem_ch10). 7996 7997 -- The other fields of a compilation unit are copied as usual 7998 7999 elsif Nkind (N) = N_Compilation_Unit then 8000 8001 -- This code can only be executed when not instantiating, because in 8002 -- the copy made for an instantiation, the compilation unit node has 8003 -- disappeared at the point that a stub is replaced by its proper 8004 -- body. 8005 8006 pragma Assert (not Instantiating); 8007 8008 Set_Context_Items (New_N, 8009 Copy_Generic_List (Context_Items (N), New_N)); 8010 8011 Set_Unit (New_N, 8012 Copy_Generic_Node (Unit (N), New_N, Instantiating => False)); 8013 8014 Set_First_Inlined_Subprogram (New_N, 8015 Copy_Generic_Node 8016 (First_Inlined_Subprogram (N), New_N, Instantiating => False)); 8017 8018 Set_Aux_Decls_Node 8019 (New_N, 8020 Copy_Generic_Node 8021 (Aux_Decls_Node (N), New_N, Instantiating => False)); 8022 8023 -- For an assignment node, the assignment is known to be semantically 8024 -- legal if we are instantiating the template. This avoids incorrect 8025 -- diagnostics in generated code. 8026 8027 elsif Nkind (N) = N_Assignment_Statement then 8028 8029 -- Copy name and expression fields in usual manner 8030 8031 Set_Name (New_N, 8032 Copy_Generic_Node (Name (N), New_N, Instantiating)); 8033 8034 Set_Expression (New_N, 8035 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 8036 8037 if Instantiating then 8038 Set_Assignment_OK (Name (New_N), True); 8039 end if; 8040 8041 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 8042 if not Instantiating then 8043 Set_Associated_Node (N, New_N); 8044 8045 else 8046 if Present (Get_Associated_Node (N)) 8047 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 8048 then 8049 -- In the generic the aggregate has some composite type. If at 8050 -- the point of instantiation the type has a private view, 8051 -- install the full view (and that of its ancestors, if any). 8052 8053 declare 8054 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 8055 Rt : Entity_Id; 8056 8057 begin 8058 if Present (T) and then Is_Private_Type (T) then 8059 Switch_View (T); 8060 end if; 8061 8062 if Present (T) 8063 and then Is_Tagged_Type (T) 8064 and then Is_Derived_Type (T) 8065 then 8066 Rt := Root_Type (T); 8067 8068 loop 8069 T := Etype (T); 8070 8071 if Is_Private_Type (T) then 8072 Switch_View (T); 8073 end if; 8074 8075 exit when T = Rt; 8076 end loop; 8077 end if; 8078 end; 8079 end if; 8080 end if; 8081 8082 -- Do not copy the associated node, which points to the generic copy 8083 -- of the aggregate. 8084 8085 declare 8086 use Atree.Unchecked_Access; 8087 -- This code section is part of the implementation of an untyped 8088 -- tree traversal, so it needs direct access to node fields. 8089 8090 begin 8091 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 8092 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 8093 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 8094 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 8095 end; 8096 8097 -- Allocators do not have an identifier denoting the access type, so we 8098 -- must locate it through the expression to check whether the views are 8099 -- consistent. 8100 8101 elsif Nkind (N) = N_Allocator 8102 and then Nkind (Expression (N)) = N_Qualified_Expression 8103 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 8104 and then Instantiating 8105 then 8106 declare 8107 T : constant Node_Id := 8108 Get_Associated_Node (Subtype_Mark (Expression (N))); 8109 Acc_T : Entity_Id; 8110 8111 begin 8112 if Present (T) then 8113 8114 -- Retrieve the allocator node in the generic copy 8115 8116 Acc_T := Etype (Parent (Parent (T))); 8117 8118 if Present (Acc_T) and then Is_Private_Type (Acc_T) then 8119 Switch_View (Acc_T); 8120 end if; 8121 end if; 8122 8123 Copy_Descendants; 8124 end; 8125 8126 -- For a proper body, we must catch the case of a proper body that 8127 -- replaces a stub. This represents the point at which a separate 8128 -- compilation unit, and hence template file, may be referenced, so we 8129 -- must make a new source instantiation entry for the template of the 8130 -- subunit, and ensure that all nodes in the subunit are adjusted using 8131 -- this new source instantiation entry. 8132 8133 elsif Nkind (N) in N_Proper_Body then 8134 declare 8135 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 8136 begin 8137 if Instantiating and then Was_Originally_Stub (N) then 8138 Create_Instantiation_Source 8139 (Instantiation_Node, 8140 Defining_Entity (N), 8141 S_Adjustment); 8142 8143 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 8144 end if; 8145 8146 -- Now copy the fields of the proper body, using the new 8147 -- adjustment factor if one was needed as per test above. 8148 8149 Copy_Descendants; 8150 8151 -- Restore the original adjustment factor 8152 8153 S_Adjustment := Save_Adjustment; 8154 end; 8155 8156 elsif Nkind (N) = N_Pragma and then Instantiating then 8157 8158 -- Do not copy Comment or Ident pragmas their content is relevant to 8159 -- the generic unit, not to the instantiating unit. 8160 8161 if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then 8162 New_N := Make_Null_Statement (Sloc (N)); 8163 8164 -- Do not copy pragmas generated from aspects because the pragmas do 8165 -- not carry any semantic information, plus they will be regenerated 8166 -- in the instance. 8167 8168 -- However, generating C we need to copy them since postconditions 8169 -- are inlined by the front end, and the front-end inlining machinery 8170 -- relies on this routine to perform inlining. 8171 8172 elsif From_Aspect_Specification (N) 8173 and then not Modify_Tree_For_C 8174 then 8175 New_N := Make_Null_Statement (Sloc (N)); 8176 8177 else 8178 Copy_Descendants; 8179 end if; 8180 8181 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 8182 8183 -- No descendant fields need traversing 8184 8185 null; 8186 8187 elsif Nkind (N) = N_String_Literal 8188 and then Present (Etype (N)) 8189 and then Instantiating 8190 then 8191 -- If the string is declared in an outer scope, the string_literal 8192 -- subtype created for it may have the wrong scope. Force reanalysis 8193 -- of the constant to generate a new itype in the proper context. 8194 8195 Set_Etype (New_N, Empty); 8196 Set_Analyzed (New_N, False); 8197 8198 -- For the remaining nodes, copy their descendants recursively 8199 8200 else 8201 Copy_Descendants; 8202 8203 if Instantiating and then Nkind (N) = N_Subprogram_Body then 8204 Set_Generic_Parent (Specification (New_N), N); 8205 8206 -- Should preserve Corresponding_Spec??? (12.3(14)) 8207 end if; 8208 end if; 8209 8210 -- Propagate dimensions if present, so that they are reflected in the 8211 -- instance. 8212 8213 if Nkind (N) in N_Has_Etype 8214 and then (Nkind (N) in N_Op or else Is_Entity_Name (N)) 8215 and then Present (Etype (N)) 8216 and then Is_Floating_Point_Type (Etype (N)) 8217 and then Has_Dimension_System (Etype (N)) 8218 then 8219 Copy_Dimensions (N, New_N); 8220 end if; 8221 8222 return New_N; 8223 end Copy_Generic_Node; 8224 8225 ---------------------------- 8226 -- Denotes_Formal_Package -- 8227 ---------------------------- 8228 8229 function Denotes_Formal_Package 8230 (Pack : Entity_Id; 8231 On_Exit : Boolean := False; 8232 Instance : Entity_Id := Empty) return Boolean 8233 is 8234 Par : Entity_Id; 8235 Scop : constant Entity_Id := Scope (Pack); 8236 E : Entity_Id; 8237 8238 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 8239 -- The package in question may be an actual for a previous formal 8240 -- package P of the current instance, so examine its actuals as well. 8241 -- This must be recursive over other formal packages. 8242 8243 ---------------------------------- 8244 -- Is_Actual_Of_Previous_Formal -- 8245 ---------------------------------- 8246 8247 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 8248 E1 : Entity_Id; 8249 8250 begin 8251 E1 := First_Entity (P); 8252 while Present (E1) and then E1 /= Instance loop 8253 if Ekind (E1) = E_Package 8254 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 8255 then 8256 if Renamed_Object (E1) = Pack then 8257 return True; 8258 8259 elsif E1 = P or else Renamed_Object (E1) = P then 8260 return False; 8261 8262 elsif Is_Actual_Of_Previous_Formal (E1) then 8263 return True; 8264 end if; 8265 end if; 8266 8267 Next_Entity (E1); 8268 end loop; 8269 8270 return False; 8271 end Is_Actual_Of_Previous_Formal; 8272 8273 -- Start of processing for Denotes_Formal_Package 8274 8275 begin 8276 if On_Exit then 8277 Par := 8278 Instance_Envs.Table 8279 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 8280 else 8281 Par := Current_Instantiated_Parent.Act_Id; 8282 end if; 8283 8284 if Ekind (Scop) = E_Generic_Package 8285 or else Nkind (Unit_Declaration_Node (Scop)) = 8286 N_Generic_Subprogram_Declaration 8287 then 8288 return True; 8289 8290 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 8291 N_Formal_Package_Declaration 8292 then 8293 return True; 8294 8295 elsif No (Par) then 8296 return False; 8297 8298 else 8299 -- Check whether this package is associated with a formal package of 8300 -- the enclosing instantiation. Iterate over the list of renamings. 8301 8302 E := First_Entity (Par); 8303 while Present (E) loop 8304 if Ekind (E) /= E_Package 8305 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 8306 then 8307 null; 8308 8309 elsif Renamed_Object (E) = Par then 8310 return False; 8311 8312 elsif Renamed_Object (E) = Pack then 8313 return True; 8314 8315 elsif Is_Actual_Of_Previous_Formal (E) then 8316 return True; 8317 8318 end if; 8319 8320 Next_Entity (E); 8321 end loop; 8322 8323 return False; 8324 end if; 8325 end Denotes_Formal_Package; 8326 8327 ----------------- 8328 -- End_Generic -- 8329 ----------------- 8330 8331 procedure End_Generic is 8332 begin 8333 -- ??? More things could be factored out in this routine. Should 8334 -- probably be done at a later stage. 8335 8336 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 8337 Generic_Flags.Decrement_Last; 8338 8339 Expander_Mode_Restore; 8340 end End_Generic; 8341 8342 ------------- 8343 -- Earlier -- 8344 ------------- 8345 8346 function Earlier (N1, N2 : Node_Id) return Boolean is 8347 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 8348 -- Find distance from given node to enclosing compilation unit 8349 8350 ---------------- 8351 -- Find_Depth -- 8352 ---------------- 8353 8354 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 8355 begin 8356 while Present (P) 8357 and then Nkind (P) /= N_Compilation_Unit 8358 loop 8359 P := True_Parent (P); 8360 D := D + 1; 8361 end loop; 8362 end Find_Depth; 8363 8364 -- Local declarations 8365 8366 D1 : Integer := 0; 8367 D2 : Integer := 0; 8368 P1 : Node_Id := N1; 8369 P2 : Node_Id := N2; 8370 T1 : Source_Ptr; 8371 T2 : Source_Ptr; 8372 8373 -- Start of processing for Earlier 8374 8375 begin 8376 Find_Depth (P1, D1); 8377 Find_Depth (P2, D2); 8378 8379 if P1 /= P2 then 8380 return False; 8381 else 8382 P1 := N1; 8383 P2 := N2; 8384 end if; 8385 8386 while D1 > D2 loop 8387 P1 := True_Parent (P1); 8388 D1 := D1 - 1; 8389 end loop; 8390 8391 while D2 > D1 loop 8392 P2 := True_Parent (P2); 8393 D2 := D2 - 1; 8394 end loop; 8395 8396 -- At this point P1 and P2 are at the same distance from the root. 8397 -- We examine their parents until we find a common declarative list. 8398 -- If we reach the root, N1 and N2 do not descend from the same 8399 -- declarative list (e.g. one is nested in the declarative part and 8400 -- the other is in a block in the statement part) and the earlier 8401 -- one is already frozen. 8402 8403 while not Is_List_Member (P1) 8404 or else not Is_List_Member (P2) 8405 or else List_Containing (P1) /= List_Containing (P2) 8406 loop 8407 P1 := True_Parent (P1); 8408 P2 := True_Parent (P2); 8409 8410 if Nkind (Parent (P1)) = N_Subunit then 8411 P1 := Corresponding_Stub (Parent (P1)); 8412 end if; 8413 8414 if Nkind (Parent (P2)) = N_Subunit then 8415 P2 := Corresponding_Stub (Parent (P2)); 8416 end if; 8417 8418 if P1 = P2 then 8419 return False; 8420 end if; 8421 end loop; 8422 8423 -- Expanded code usually shares the source location of the original 8424 -- construct it was generated for. This however may not necessarily 8425 -- reflect the true location of the code within the tree. 8426 8427 -- Before comparing the slocs of the two nodes, make sure that we are 8428 -- working with correct source locations. Assume that P1 is to the left 8429 -- of P2. If either one does not come from source, traverse the common 8430 -- list heading towards the other node and locate the first source 8431 -- statement. 8432 8433 -- P1 P2 8434 -- ----+===+===+--------------+===+===+---- 8435 -- expanded code expanded code 8436 8437 if not Comes_From_Source (P1) then 8438 while Present (P1) loop 8439 8440 -- Neither P2 nor a source statement were located during the 8441 -- search. If we reach the end of the list, then P1 does not 8442 -- occur earlier than P2. 8443 8444 -- ----> 8445 -- start --- P2 ----- P1 --- end 8446 8447 if No (Next (P1)) then 8448 return False; 8449 8450 -- We encounter P2 while going to the right of the list. This 8451 -- means that P1 does indeed appear earlier. 8452 8453 -- ----> 8454 -- start --- P1 ===== P2 --- end 8455 -- expanded code in between 8456 8457 elsif P1 = P2 then 8458 return True; 8459 8460 -- No need to look any further since we have located a source 8461 -- statement. 8462 8463 elsif Comes_From_Source (P1) then 8464 exit; 8465 end if; 8466 8467 -- Keep going right 8468 8469 Next (P1); 8470 end loop; 8471 end if; 8472 8473 if not Comes_From_Source (P2) then 8474 while Present (P2) loop 8475 8476 -- Neither P1 nor a source statement were located during the 8477 -- search. If we reach the start of the list, then P1 does not 8478 -- occur earlier than P2. 8479 8480 -- <---- 8481 -- start --- P2 --- P1 --- end 8482 8483 if No (Prev (P2)) then 8484 return False; 8485 8486 -- We encounter P1 while going to the left of the list. This 8487 -- means that P1 does indeed appear earlier. 8488 8489 -- <---- 8490 -- start --- P1 ===== P2 --- end 8491 -- expanded code in between 8492 8493 elsif P2 = P1 then 8494 return True; 8495 8496 -- No need to look any further since we have located a source 8497 -- statement. 8498 8499 elsif Comes_From_Source (P2) then 8500 exit; 8501 end if; 8502 8503 -- Keep going left 8504 8505 Prev (P2); 8506 end loop; 8507 end if; 8508 8509 -- At this point either both nodes came from source or we approximated 8510 -- their source locations through neighboring source statements. 8511 8512 T1 := Top_Level_Location (Sloc (P1)); 8513 T2 := Top_Level_Location (Sloc (P2)); 8514 8515 -- When two nodes come from the same instance, they have identical top 8516 -- level locations. To determine proper relation within the tree, check 8517 -- their locations within the template. 8518 8519 if T1 = T2 then 8520 return Sloc (P1) < Sloc (P2); 8521 8522 -- The two nodes either come from unrelated instances or do not come 8523 -- from instantiated code at all. 8524 8525 else 8526 return T1 < T2; 8527 end if; 8528 end Earlier; 8529 8530 ---------------------- 8531 -- Find_Actual_Type -- 8532 ---------------------- 8533 8534 function Find_Actual_Type 8535 (Typ : Entity_Id; 8536 Gen_Type : Entity_Id) return Entity_Id 8537 is 8538 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 8539 T : Entity_Id; 8540 8541 begin 8542 -- Special processing only applies to child units 8543 8544 if not Is_Child_Unit (Gen_Scope) then 8545 return Get_Instance_Of (Typ); 8546 8547 -- If designated or component type is itself a formal of the child unit, 8548 -- its instance is available. 8549 8550 elsif Scope (Typ) = Gen_Scope then 8551 return Get_Instance_Of (Typ); 8552 8553 -- If the array or access type is not declared in the parent unit, 8554 -- no special processing needed. 8555 8556 elsif not Is_Generic_Type (Typ) 8557 and then Scope (Gen_Scope) /= Scope (Typ) 8558 then 8559 return Get_Instance_Of (Typ); 8560 8561 -- Otherwise, retrieve designated or component type by visibility 8562 8563 else 8564 T := Current_Entity (Typ); 8565 while Present (T) loop 8566 if In_Open_Scopes (Scope (T)) then 8567 return T; 8568 elsif Is_Generic_Actual_Type (T) then 8569 return T; 8570 end if; 8571 8572 T := Homonym (T); 8573 end loop; 8574 8575 return Typ; 8576 end if; 8577 end Find_Actual_Type; 8578 8579 ---------------------------- 8580 -- Freeze_Subprogram_Body -- 8581 ---------------------------- 8582 8583 procedure Freeze_Subprogram_Body 8584 (Inst_Node : Node_Id; 8585 Gen_Body : Node_Id; 8586 Pack_Id : Entity_Id) 8587 is 8588 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 8589 Par : constant Entity_Id := Scope (Gen_Unit); 8590 E_G_Id : Entity_Id; 8591 Enc_G : Entity_Id; 8592 Enc_I : Node_Id; 8593 F_Node : Node_Id; 8594 8595 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 8596 -- Find innermost package body that encloses the given node, and which 8597 -- is not a compilation unit. Freeze nodes for the instance, or for its 8598 -- enclosing body, may be inserted after the enclosing_body of the 8599 -- generic unit. Used to determine proper placement of freeze node for 8600 -- both package and subprogram instances. 8601 8602 function Package_Freeze_Node (B : Node_Id) return Node_Id; 8603 -- Find entity for given package body, and locate or create a freeze 8604 -- node for it. 8605 8606 ---------------------------- 8607 -- Enclosing_Package_Body -- 8608 ---------------------------- 8609 8610 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 8611 P : Node_Id; 8612 8613 begin 8614 P := Parent (N); 8615 while Present (P) 8616 and then Nkind (Parent (P)) /= N_Compilation_Unit 8617 loop 8618 if Nkind (P) = N_Package_Body then 8619 if Nkind (Parent (P)) = N_Subunit then 8620 return Corresponding_Stub (Parent (P)); 8621 else 8622 return P; 8623 end if; 8624 end if; 8625 8626 P := True_Parent (P); 8627 end loop; 8628 8629 return Empty; 8630 end Enclosing_Package_Body; 8631 8632 ------------------------- 8633 -- Package_Freeze_Node -- 8634 ------------------------- 8635 8636 function Package_Freeze_Node (B : Node_Id) return Node_Id is 8637 Id : Entity_Id; 8638 8639 begin 8640 if Nkind (B) = N_Package_Body then 8641 Id := Corresponding_Spec (B); 8642 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 8643 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 8644 end if; 8645 8646 Ensure_Freeze_Node (Id); 8647 return Freeze_Node (Id); 8648 end Package_Freeze_Node; 8649 8650 -- Start of processing for Freeze_Subprogram_Body 8651 8652 begin 8653 -- If the instance and the generic body appear within the same unit, and 8654 -- the instance precedes the generic, the freeze node for the instance 8655 -- must appear after that of the generic. If the generic is nested 8656 -- within another instance I2, then current instance must be frozen 8657 -- after I2. In both cases, the freeze nodes are those of enclosing 8658 -- packages. Otherwise, the freeze node is placed at the end of the 8659 -- current declarative part. 8660 8661 Enc_G := Enclosing_Package_Body (Gen_Body); 8662 Enc_I := Enclosing_Package_Body (Inst_Node); 8663 Ensure_Freeze_Node (Pack_Id); 8664 F_Node := Freeze_Node (Pack_Id); 8665 8666 if Is_Generic_Instance (Par) 8667 and then Present (Freeze_Node (Par)) 8668 and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) 8669 then 8670 -- The parent was a premature instantiation. Insert freeze node at 8671 -- the end the current declarative part. 8672 8673 if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then 8674 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8675 8676 -- Handle the following case: 8677 -- 8678 -- package Parent_Inst is new ... 8679 -- Parent_Inst [] 8680 -- 8681 -- procedure P ... -- this body freezes Parent_Inst 8682 -- 8683 -- package Inst is new ... 8684 -- 8685 -- In this particular scenario, the freeze node for Inst must be 8686 -- inserted in the same manner as that of Parent_Inst - before the 8687 -- next source body or at the end of the declarative list (body not 8688 -- available). If body P did not exist and Parent_Inst was frozen 8689 -- after Inst, either by a body following Inst or at the end of the 8690 -- declarative region, the freeze node for Inst must be inserted 8691 -- after that of Parent_Inst. This relation is established by 8692 -- comparing the Slocs of Parent_Inst freeze node and Inst. 8693 8694 elsif List_Containing (Get_Unit_Instantiation_Node (Par)) = 8695 List_Containing (Inst_Node) 8696 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 8697 then 8698 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8699 8700 else 8701 Insert_After (Freeze_Node (Par), F_Node); 8702 end if; 8703 8704 -- The body enclosing the instance should be frozen after the body that 8705 -- includes the generic, because the body of the instance may make 8706 -- references to entities therein. If the two are not in the same 8707 -- declarative part, or if the one enclosing the instance is frozen 8708 -- already, freeze the instance at the end of the current declarative 8709 -- part. 8710 8711 elsif Is_Generic_Instance (Par) 8712 and then Present (Freeze_Node (Par)) 8713 and then Present (Enc_I) 8714 then 8715 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) 8716 or else 8717 (Nkind (Enc_I) = N_Package_Body 8718 and then 8719 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) 8720 then 8721 -- The enclosing package may contain several instances. Rather 8722 -- than computing the earliest point at which to insert its freeze 8723 -- node, we place it at the end of the declarative part of the 8724 -- parent of the generic. 8725 8726 Insert_Freeze_Node_For_Instance 8727 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 8728 end if; 8729 8730 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8731 8732 elsif Present (Enc_G) 8733 and then Present (Enc_I) 8734 and then Enc_G /= Enc_I 8735 and then Earlier (Inst_Node, Gen_Body) 8736 then 8737 if Nkind (Enc_G) = N_Package_Body then 8738 E_G_Id := 8739 Corresponding_Spec (Enc_G); 8740 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 8741 E_G_Id := 8742 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 8743 end if; 8744 8745 -- Freeze package that encloses instance, and place node after the 8746 -- package that encloses generic. If enclosing package is already 8747 -- frozen we have to assume it is at the proper place. This may be a 8748 -- potential ABE that requires dynamic checking. Do not add a freeze 8749 -- node if the package that encloses the generic is inside the body 8750 -- that encloses the instance, because the freeze node would be in 8751 -- the wrong scope. Additional contortions needed if the bodies are 8752 -- within a subunit. 8753 8754 declare 8755 Enclosing_Body : Node_Id; 8756 8757 begin 8758 if Nkind (Enc_I) = N_Package_Body_Stub then 8759 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 8760 else 8761 Enclosing_Body := Enc_I; 8762 end if; 8763 8764 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 8765 Insert_Freeze_Node_For_Instance 8766 (Enc_G, Package_Freeze_Node (Enc_I)); 8767 end if; 8768 end; 8769 8770 -- Freeze enclosing subunit before instance 8771 8772 Ensure_Freeze_Node (E_G_Id); 8773 8774 if not Is_List_Member (Freeze_Node (E_G_Id)) then 8775 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 8776 end if; 8777 8778 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8779 8780 else 8781 -- If none of the above, insert freeze node at the end of the current 8782 -- declarative part. 8783 8784 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8785 end if; 8786 end Freeze_Subprogram_Body; 8787 8788 ---------------- 8789 -- Get_Gen_Id -- 8790 ---------------- 8791 8792 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 8793 begin 8794 return Generic_Renamings.Table (E).Gen_Id; 8795 end Get_Gen_Id; 8796 8797 --------------------- 8798 -- Get_Instance_Of -- 8799 --------------------- 8800 8801 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 8802 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 8803 8804 begin 8805 if Res /= Assoc_Null then 8806 return Generic_Renamings.Table (Res).Act_Id; 8807 8808 else 8809 -- On exit, entity is not instantiated: not a generic parameter, or 8810 -- else parameter of an inner generic unit. 8811 8812 return A; 8813 end if; 8814 end Get_Instance_Of; 8815 8816 --------------------------------- 8817 -- Get_Unit_Instantiation_Node -- 8818 --------------------------------- 8819 8820 function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is 8821 Decl : Node_Id := Unit_Declaration_Node (A); 8822 Inst : Node_Id; 8823 8824 begin 8825 -- If the Package_Instantiation attribute has been set on the package 8826 -- entity, then use it directly when it (or its Original_Node) refers 8827 -- to an N_Package_Instantiation node. In principle it should be 8828 -- possible to have this field set in all cases, which should be 8829 -- investigated, and would allow this function to be significantly 8830 -- simplified. ??? 8831 8832 Inst := Package_Instantiation (A); 8833 8834 if Present (Inst) then 8835 if Nkind (Inst) = N_Package_Instantiation then 8836 return Inst; 8837 8838 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 8839 return Original_Node (Inst); 8840 end if; 8841 end if; 8842 8843 -- If the instantiation is a compilation unit that does not need body 8844 -- then the instantiation node has been rewritten as a package 8845 -- declaration for the instance, and we return the original node. 8846 8847 -- If it is a compilation unit and the instance node has not been 8848 -- rewritten, then it is still the unit of the compilation. Finally, if 8849 -- a body is present, this is a parent of the main unit whose body has 8850 -- been compiled for inlining purposes, and the instantiation node has 8851 -- been rewritten with the instance body. 8852 8853 -- Otherwise the instantiation node appears after the declaration. If 8854 -- the entity is a formal package, the declaration may have been 8855 -- rewritten as a generic declaration (in the case of a formal with box) 8856 -- or left as a formal package declaration if it has actuals, and is 8857 -- found with a forward search. 8858 8859 if Nkind (Parent (Decl)) = N_Compilation_Unit then 8860 if Nkind (Decl) = N_Package_Declaration 8861 and then Present (Corresponding_Body (Decl)) 8862 then 8863 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 8864 end if; 8865 8866 if Nkind_In (Original_Node (Decl), N_Function_Instantiation, 8867 N_Package_Instantiation, 8868 N_Procedure_Instantiation) 8869 then 8870 return Original_Node (Decl); 8871 else 8872 return Unit (Parent (Decl)); 8873 end if; 8874 8875 elsif Nkind (Decl) = N_Package_Declaration 8876 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 8877 then 8878 return Original_Node (Decl); 8879 8880 else 8881 Inst := Next (Decl); 8882 while not Nkind_In (Inst, N_Formal_Package_Declaration, 8883 N_Function_Instantiation, 8884 N_Package_Instantiation, 8885 N_Procedure_Instantiation) 8886 loop 8887 Next (Inst); 8888 end loop; 8889 8890 return Inst; 8891 end if; 8892 end Get_Unit_Instantiation_Node; 8893 8894 ------------------------ 8895 -- Has_Been_Exchanged -- 8896 ------------------------ 8897 8898 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 8899 Next : Elmt_Id; 8900 8901 begin 8902 Next := First_Elmt (Exchanged_Views); 8903 while Present (Next) loop 8904 if Full_View (Node (Next)) = E then 8905 return True; 8906 end if; 8907 8908 Next_Elmt (Next); 8909 end loop; 8910 8911 return False; 8912 end Has_Been_Exchanged; 8913 8914 ---------- 8915 -- Hash -- 8916 ---------- 8917 8918 function Hash (F : Entity_Id) return HTable_Range is 8919 begin 8920 return HTable_Range (F mod HTable_Size); 8921 end Hash; 8922 8923 ------------------------ 8924 -- Hide_Current_Scope -- 8925 ------------------------ 8926 8927 procedure Hide_Current_Scope is 8928 C : constant Entity_Id := Current_Scope; 8929 E : Entity_Id; 8930 8931 begin 8932 Set_Is_Hidden_Open_Scope (C); 8933 8934 E := First_Entity (C); 8935 while Present (E) loop 8936 if Is_Immediately_Visible (E) then 8937 Set_Is_Immediately_Visible (E, False); 8938 Append_Elmt (E, Hidden_Entities); 8939 end if; 8940 8941 Next_Entity (E); 8942 end loop; 8943 8944 -- Make the scope name invisible as well. This is necessary, but might 8945 -- conflict with calls to Rtsfind later on, in case the scope is a 8946 -- predefined one. There is no clean solution to this problem, so for 8947 -- now we depend on the user not redefining Standard itself in one of 8948 -- the parent units. 8949 8950 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 8951 Set_Is_Immediately_Visible (C, False); 8952 Append_Elmt (C, Hidden_Entities); 8953 end if; 8954 8955 end Hide_Current_Scope; 8956 8957 -------------- 8958 -- Init_Env -- 8959 -------------- 8960 8961 procedure Init_Env is 8962 Saved : Instance_Env; 8963 8964 begin 8965 Saved.Instantiated_Parent := Current_Instantiated_Parent; 8966 Saved.Exchanged_Views := Exchanged_Views; 8967 Saved.Hidden_Entities := Hidden_Entities; 8968 Saved.Current_Sem_Unit := Current_Sem_Unit; 8969 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 8970 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 8971 8972 -- Save configuration switches. These may be reset if the unit is a 8973 -- predefined unit, and the current mode is not Ada 2005. 8974 8975 Save_Opt_Config_Switches (Saved.Switches); 8976 8977 Instance_Envs.Append (Saved); 8978 8979 Exchanged_Views := New_Elmt_List; 8980 Hidden_Entities := New_Elmt_List; 8981 8982 -- Make dummy entry for Instantiated parent. If generic unit is legal, 8983 -- this is set properly in Set_Instance_Env. 8984 8985 Current_Instantiated_Parent := 8986 (Current_Scope, Current_Scope, Assoc_Null); 8987 end Init_Env; 8988 8989 ------------------------------ 8990 -- In_Same_Declarative_Part -- 8991 ------------------------------ 8992 8993 function In_Same_Declarative_Part 8994 (F_Node : Node_Id; 8995 Inst : Node_Id) return Boolean 8996 is 8997 Decls : constant Node_Id := Parent (F_Node); 8998 Nod : Node_Id; 8999 9000 begin 9001 Nod := Parent (Inst); 9002 while Present (Nod) loop 9003 if Nod = Decls then 9004 return True; 9005 9006 elsif Nkind_In (Nod, N_Subprogram_Body, 9007 N_Package_Body, 9008 N_Package_Declaration, 9009 N_Task_Body, 9010 N_Protected_Body, 9011 N_Block_Statement) 9012 then 9013 return False; 9014 9015 elsif Nkind (Nod) = N_Subunit then 9016 Nod := Corresponding_Stub (Nod); 9017 9018 elsif Nkind (Nod) = N_Compilation_Unit then 9019 return False; 9020 9021 else 9022 Nod := Parent (Nod); 9023 end if; 9024 end loop; 9025 9026 return False; 9027 end In_Same_Declarative_Part; 9028 9029 --------------------- 9030 -- In_Main_Context -- 9031 --------------------- 9032 9033 function In_Main_Context (E : Entity_Id) return Boolean is 9034 Context : List_Id; 9035 Clause : Node_Id; 9036 Nam : Node_Id; 9037 9038 begin 9039 if not Is_Compilation_Unit (E) 9040 or else Ekind (E) /= E_Package 9041 or else In_Private_Part (E) 9042 then 9043 return False; 9044 end if; 9045 9046 Context := Context_Items (Cunit (Main_Unit)); 9047 9048 Clause := First (Context); 9049 while Present (Clause) loop 9050 if Nkind (Clause) = N_With_Clause then 9051 Nam := Name (Clause); 9052 9053 -- If the current scope is part of the context of the main unit, 9054 -- analysis of the corresponding with_clause is not complete, and 9055 -- the entity is not set. We use the Chars field directly, which 9056 -- might produce false positives in rare cases, but guarantees 9057 -- that we produce all the instance bodies we will need. 9058 9059 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 9060 or else (Nkind (Nam) = N_Selected_Component 9061 and then Chars (Selector_Name (Nam)) = Chars (E)) 9062 then 9063 return True; 9064 end if; 9065 end if; 9066 9067 Next (Clause); 9068 end loop; 9069 9070 return False; 9071 end In_Main_Context; 9072 9073 --------------------- 9074 -- Inherit_Context -- 9075 --------------------- 9076 9077 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 9078 Current_Context : List_Id; 9079 Current_Unit : Node_Id; 9080 Item : Node_Id; 9081 New_I : Node_Id; 9082 9083 Clause : Node_Id; 9084 OK : Boolean; 9085 Lib_Unit : Node_Id; 9086 9087 begin 9088 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 9089 9090 -- The inherited context is attached to the enclosing compilation 9091 -- unit. This is either the main unit, or the declaration for the 9092 -- main unit (in case the instantiation appears within the package 9093 -- declaration and the main unit is its body). 9094 9095 Current_Unit := Parent (Inst); 9096 while Present (Current_Unit) 9097 and then Nkind (Current_Unit) /= N_Compilation_Unit 9098 loop 9099 Current_Unit := Parent (Current_Unit); 9100 end loop; 9101 9102 Current_Context := Context_Items (Current_Unit); 9103 9104 Item := First (Context_Items (Parent (Gen_Decl))); 9105 while Present (Item) loop 9106 if Nkind (Item) = N_With_Clause then 9107 Lib_Unit := Library_Unit (Item); 9108 9109 -- Take care to prevent direct cyclic with's 9110 9111 if Lib_Unit /= Current_Unit then 9112 9113 -- Do not add a unit if it is already in the context 9114 9115 Clause := First (Current_Context); 9116 OK := True; 9117 while Present (Clause) loop 9118 if Nkind (Clause) = N_With_Clause 9119 and then Library_Unit (Clause) = Lib_Unit 9120 then 9121 OK := False; 9122 exit; 9123 end if; 9124 9125 Next (Clause); 9126 end loop; 9127 9128 if OK then 9129 New_I := New_Copy (Item); 9130 Set_Implicit_With (New_I); 9131 9132 Append (New_I, Current_Context); 9133 end if; 9134 end if; 9135 end if; 9136 9137 Next (Item); 9138 end loop; 9139 end if; 9140 end Inherit_Context; 9141 9142 ---------------- 9143 -- Initialize -- 9144 ---------------- 9145 9146 procedure Initialize is 9147 begin 9148 Generic_Renamings.Init; 9149 Instance_Envs.Init; 9150 Generic_Flags.Init; 9151 Generic_Renamings_HTable.Reset; 9152 Circularity_Detected := False; 9153 Exchanged_Views := No_Elist; 9154 Hidden_Entities := No_Elist; 9155 end Initialize; 9156 9157 ------------------------------------- 9158 -- Insert_Freeze_Node_For_Instance -- 9159 ------------------------------------- 9160 9161 procedure Insert_Freeze_Node_For_Instance 9162 (N : Node_Id; 9163 F_Node : Node_Id) 9164 is 9165 Decl : Node_Id; 9166 Decls : List_Id; 9167 Inst : Entity_Id; 9168 Par_N : Node_Id; 9169 9170 function Enclosing_Body (N : Node_Id) return Node_Id; 9171 -- Find enclosing package or subprogram body, if any. Freeze node may 9172 -- be placed at end of current declarative list if previous instance 9173 -- and current one have different enclosing bodies. 9174 9175 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 9176 -- Find the local instance, if any, that declares the generic that is 9177 -- being instantiated. If present, the freeze node for this instance 9178 -- must follow the freeze node for the previous instance. 9179 9180 -------------------- 9181 -- Enclosing_Body -- 9182 -------------------- 9183 9184 function Enclosing_Body (N : Node_Id) return Node_Id is 9185 P : Node_Id; 9186 9187 begin 9188 P := Parent (N); 9189 while Present (P) 9190 and then Nkind (Parent (P)) /= N_Compilation_Unit 9191 loop 9192 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 9193 if Nkind (Parent (P)) = N_Subunit then 9194 return Corresponding_Stub (Parent (P)); 9195 else 9196 return P; 9197 end if; 9198 end if; 9199 9200 P := True_Parent (P); 9201 end loop; 9202 9203 return Empty; 9204 end Enclosing_Body; 9205 9206 ----------------------- 9207 -- Previous_Instance -- 9208 ----------------------- 9209 9210 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 9211 S : Entity_Id; 9212 9213 begin 9214 S := Scope (Gen); 9215 while Present (S) and then S /= Standard_Standard loop 9216 if Is_Generic_Instance (S) 9217 and then In_Same_Source_Unit (S, N) 9218 then 9219 return S; 9220 end if; 9221 9222 S := Scope (S); 9223 end loop; 9224 9225 return Empty; 9226 end Previous_Instance; 9227 9228 -- Start of processing for Insert_Freeze_Node_For_Instance 9229 9230 begin 9231 if not Is_List_Member (F_Node) then 9232 Decl := N; 9233 Decls := List_Containing (N); 9234 Inst := Entity (F_Node); 9235 Par_N := Parent (Decls); 9236 9237 -- When processing a subprogram instantiation, utilize the actual 9238 -- subprogram instantiation rather than its package wrapper as it 9239 -- carries all the context information. 9240 9241 if Is_Wrapper_Package (Inst) then 9242 Inst := Related_Instance (Inst); 9243 end if; 9244 9245 -- If this is a package instance, check whether the generic is 9246 -- declared in a previous instance and the current instance is 9247 -- not within the previous one. 9248 9249 if Present (Generic_Parent (Parent (Inst))) 9250 and then Is_In_Main_Unit (N) 9251 then 9252 declare 9253 Enclosing_N : constant Node_Id := Enclosing_Body (N); 9254 Par_I : constant Entity_Id := 9255 Previous_Instance 9256 (Generic_Parent (Parent (Inst))); 9257 Scop : Entity_Id; 9258 9259 begin 9260 if Present (Par_I) 9261 and then Earlier (N, Freeze_Node (Par_I)) 9262 then 9263 Scop := Scope (Inst); 9264 9265 -- If the current instance is within the one that contains 9266 -- the generic, the freeze node for the current one must 9267 -- appear in the current declarative part. Ditto, if the 9268 -- current instance is within another package instance or 9269 -- within a body that does not enclose the current instance. 9270 -- In these three cases the freeze node of the previous 9271 -- instance is not relevant. 9272 9273 while Present (Scop) and then Scop /= Standard_Standard loop 9274 exit when Scop = Par_I 9275 or else 9276 (Is_Generic_Instance (Scop) 9277 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 9278 Scop := Scope (Scop); 9279 end loop; 9280 9281 -- Previous instance encloses current instance 9282 9283 if Scop = Par_I then 9284 null; 9285 9286 -- If the next node is a source body we must freeze in 9287 -- the current scope as well. 9288 9289 elsif Present (Next (N)) 9290 and then Nkind_In (Next (N), N_Subprogram_Body, 9291 N_Package_Body) 9292 and then Comes_From_Source (Next (N)) 9293 then 9294 null; 9295 9296 -- Current instance is within an unrelated instance 9297 9298 elsif Is_Generic_Instance (Scop) then 9299 null; 9300 9301 -- Current instance is within an unrelated body 9302 9303 elsif Present (Enclosing_N) 9304 and then Enclosing_N /= Enclosing_Body (Par_I) 9305 then 9306 null; 9307 9308 else 9309 Insert_After (Freeze_Node (Par_I), F_Node); 9310 return; 9311 end if; 9312 end if; 9313 end; 9314 end if; 9315 9316 -- When the instantiation occurs in a package declaration, append the 9317 -- freeze node to the private declarations (if any). 9318 9319 if Nkind (Par_N) = N_Package_Specification 9320 and then Decls = Visible_Declarations (Par_N) 9321 and then Present (Private_Declarations (Par_N)) 9322 and then not Is_Empty_List (Private_Declarations (Par_N)) 9323 then 9324 Decls := Private_Declarations (Par_N); 9325 Decl := First (Decls); 9326 end if; 9327 9328 -- Determine the proper freeze point of a package instantiation. We 9329 -- adhere to the general rule of a package or subprogram body causing 9330 -- freezing of anything before it in the same declarative region. In 9331 -- this case, the proper freeze point of a package instantiation is 9332 -- before the first source body which follows, or before a stub. This 9333 -- ensures that entities coming from the instance are already frozen 9334 -- and usable in source bodies. 9335 9336 if Nkind (Par_N) /= N_Package_Declaration 9337 and then Ekind (Inst) = E_Package 9338 and then Is_Generic_Instance (Inst) 9339 and then 9340 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 9341 then 9342 while Present (Decl) loop 9343 if (Nkind (Decl) in N_Unit_Body 9344 or else 9345 Nkind (Decl) in N_Body_Stub) 9346 and then Comes_From_Source (Decl) 9347 then 9348 Insert_Before (Decl, F_Node); 9349 return; 9350 end if; 9351 9352 Next (Decl); 9353 end loop; 9354 end if; 9355 9356 -- In a package declaration, or if no previous body, insert at end 9357 -- of list. 9358 9359 Set_Sloc (F_Node, Sloc (Last (Decls))); 9360 Insert_After (Last (Decls), F_Node); 9361 end if; 9362 end Insert_Freeze_Node_For_Instance; 9363 9364 ------------------ 9365 -- Install_Body -- 9366 ------------------ 9367 9368 procedure Install_Body 9369 (Act_Body : Node_Id; 9370 N : Node_Id; 9371 Gen_Body : Node_Id; 9372 Gen_Decl : Node_Id) 9373 is 9374 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean; 9375 -- Check if the generic definition and the instantiation come from 9376 -- a common scope, in which case the instance must be frozen after 9377 -- the generic body. 9378 9379 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr; 9380 -- If the instance is nested inside a generic unit, the Sloc of the 9381 -- instance indicates the place of the original definition, not the 9382 -- point of the current enclosing instance. Pending a better usage of 9383 -- Slocs to indicate instantiation places, we determine the place of 9384 -- origin of a node by finding the maximum sloc of any ancestor node. 9385 -- Why is this not equivalent to Top_Level_Location ??? 9386 9387 ------------------- 9388 -- In_Same_Scope -- 9389 ------------------- 9390 9391 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is 9392 Act_Scop : Entity_Id := Scope (Act_Id); 9393 Gen_Scop : Entity_Id := Scope (Gen_Id); 9394 9395 begin 9396 while Act_Scop /= Standard_Standard 9397 and then Gen_Scop /= Standard_Standard 9398 loop 9399 if Act_Scop = Gen_Scop then 9400 return True; 9401 end if; 9402 9403 Act_Scop := Scope (Act_Scop); 9404 Gen_Scop := Scope (Gen_Scop); 9405 end loop; 9406 9407 return False; 9408 end In_Same_Scope; 9409 9410 --------------- 9411 -- True_Sloc -- 9412 --------------- 9413 9414 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is 9415 N1 : Node_Id; 9416 Res : Source_Ptr; 9417 9418 begin 9419 Res := Sloc (N); 9420 N1 := N; 9421 while Present (N1) and then N1 /= Act_Unit loop 9422 if Sloc (N1) > Res then 9423 Res := Sloc (N1); 9424 end if; 9425 9426 N1 := Parent (N1); 9427 end loop; 9428 9429 return Res; 9430 end True_Sloc; 9431 9432 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 9433 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 9434 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 9435 Par : constant Entity_Id := Scope (Gen_Id); 9436 Gen_Unit : constant Node_Id := 9437 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 9438 9439 Body_Unit : Node_Id; 9440 F_Node : Node_Id; 9441 Must_Delay : Boolean; 9442 Orig_Body : Node_Id := Gen_Body; 9443 9444 -- Start of processing for Install_Body 9445 9446 begin 9447 -- Handle first the case of an instance with incomplete actual types. 9448 -- The instance body cannot be placed after the declaration because 9449 -- full views have not been seen yet. Any use of the non-limited views 9450 -- in the instance body requires the presence of a regular with_clause 9451 -- in the enclosing unit, and will fail if this with_clause is missing. 9452 -- We place the instance body at the beginning of the enclosing body, 9453 -- which is the unit being compiled. The freeze node for the instance 9454 -- is then placed after the instance body. 9455 9456 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) 9457 and then Expander_Active 9458 and then Ekind (Scope (Act_Id)) = E_Package 9459 then 9460 declare 9461 Scop : constant Entity_Id := Scope (Act_Id); 9462 Body_Id : constant Node_Id := 9463 Corresponding_Body (Unit_Declaration_Node (Scop)); 9464 9465 begin 9466 Ensure_Freeze_Node (Act_Id); 9467 F_Node := Freeze_Node (Act_Id); 9468 if Present (Body_Id) then 9469 Set_Is_Frozen (Act_Id, False); 9470 Prepend (Act_Body, Declarations (Parent (Body_Id))); 9471 if Is_List_Member (F_Node) then 9472 Remove (F_Node); 9473 end if; 9474 9475 Insert_After (Act_Body, F_Node); 9476 end if; 9477 end; 9478 return; 9479 end if; 9480 9481 -- If the body is a subunit, the freeze point is the corresponding stub 9482 -- in the current compilation, not the subunit itself. 9483 9484 if Nkind (Parent (Gen_Body)) = N_Subunit then 9485 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 9486 else 9487 Orig_Body := Gen_Body; 9488 end if; 9489 9490 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 9491 9492 -- If the instantiation and the generic definition appear in the same 9493 -- package declaration, this is an early instantiation. If they appear 9494 -- in the same declarative part, it is an early instantiation only if 9495 -- the generic body appears textually later, and the generic body is 9496 -- also in the main unit. 9497 9498 -- If instance is nested within a subprogram, and the generic body 9499 -- is not, the instance is delayed because the enclosing body is. If 9500 -- instance and body are within the same scope, or the same subprogram 9501 -- body, indicate explicitly that the instance is delayed. 9502 9503 Must_Delay := 9504 (Gen_Unit = Act_Unit 9505 and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, 9506 N_Package_Declaration) 9507 or else (Gen_Unit = Body_Unit 9508 and then True_Sloc (N, Act_Unit) < 9509 Sloc (Orig_Body))) 9510 and then Is_In_Main_Unit (Original_Node (Gen_Unit)) 9511 and then In_Same_Scope (Gen_Id, Act_Id)); 9512 9513 -- If this is an early instantiation, the freeze node is placed after 9514 -- the generic body. Otherwise, if the generic appears in an instance, 9515 -- we cannot freeze the current instance until the outer one is frozen. 9516 -- This is only relevant if the current instance is nested within some 9517 -- inner scope not itself within the outer instance. If this scope is 9518 -- a package body in the same declarative part as the outer instance, 9519 -- then that body needs to be frozen after the outer instance. Finally, 9520 -- if no delay is needed, we place the freeze node at the end of the 9521 -- current declarative part. 9522 9523 if Expander_Active 9524 and then (No (Freeze_Node (Act_Id)) 9525 or else not Is_List_Member (Freeze_Node (Act_Id))) 9526 then 9527 Ensure_Freeze_Node (Act_Id); 9528 F_Node := Freeze_Node (Act_Id); 9529 9530 if Must_Delay then 9531 Insert_After (Orig_Body, F_Node); 9532 9533 elsif Is_Generic_Instance (Par) 9534 and then Present (Freeze_Node (Par)) 9535 and then Scope (Act_Id) /= Par 9536 then 9537 -- Freeze instance of inner generic after instance of enclosing 9538 -- generic. 9539 9540 if In_Same_Declarative_Part (Freeze_Node (Par), N) then 9541 9542 -- Handle the following case: 9543 9544 -- package Parent_Inst is new ... 9545 -- Parent_Inst [] 9546 9547 -- procedure P ... -- this body freezes Parent_Inst 9548 9549 -- package Inst is new ... 9550 9551 -- In this particular scenario, the freeze node for Inst must 9552 -- be inserted in the same manner as that of Parent_Inst, 9553 -- before the next source body or at the end of the declarative 9554 -- list (body not available). If body P did not exist and 9555 -- Parent_Inst was frozen after Inst, either by a body 9556 -- following Inst or at the end of the declarative region, 9557 -- the freeze node for Inst must be inserted after that of 9558 -- Parent_Inst. This relation is established by comparing 9559 -- the Slocs of Parent_Inst freeze node and Inst. 9560 9561 if List_Containing (Get_Unit_Instantiation_Node (Par)) = 9562 List_Containing (N) 9563 and then Sloc (Freeze_Node (Par)) < Sloc (N) 9564 then 9565 Insert_Freeze_Node_For_Instance (N, F_Node); 9566 else 9567 Insert_After (Freeze_Node (Par), F_Node); 9568 end if; 9569 9570 -- Freeze package enclosing instance of inner generic after 9571 -- instance of enclosing generic. 9572 9573 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 9574 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) 9575 then 9576 declare 9577 Enclosing : Entity_Id; 9578 9579 begin 9580 Enclosing := Corresponding_Spec (Parent (N)); 9581 9582 if No (Enclosing) then 9583 Enclosing := Defining_Entity (Parent (N)); 9584 end if; 9585 9586 Insert_Freeze_Node_For_Instance (N, F_Node); 9587 Ensure_Freeze_Node (Enclosing); 9588 9589 if not Is_List_Member (Freeze_Node (Enclosing)) then 9590 9591 -- The enclosing context is a subunit, insert the freeze 9592 -- node after the stub. 9593 9594 if Nkind (Parent (Parent (N))) = N_Subunit then 9595 Insert_Freeze_Node_For_Instance 9596 (Corresponding_Stub (Parent (Parent (N))), 9597 Freeze_Node (Enclosing)); 9598 9599 -- The enclosing context is a package with a stub body 9600 -- which has already been replaced by the real body. 9601 -- Insert the freeze node after the actual body. 9602 9603 elsif Ekind (Enclosing) = E_Package 9604 and then Present (Body_Entity (Enclosing)) 9605 and then Was_Originally_Stub 9606 (Parent (Body_Entity (Enclosing))) 9607 then 9608 Insert_Freeze_Node_For_Instance 9609 (Parent (Body_Entity (Enclosing)), 9610 Freeze_Node (Enclosing)); 9611 9612 -- The parent instance has been frozen before the body of 9613 -- the enclosing package, insert the freeze node after 9614 -- the body. 9615 9616 elsif List_Containing (Freeze_Node (Par)) = 9617 List_Containing (Parent (N)) 9618 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 9619 then 9620 Insert_Freeze_Node_For_Instance 9621 (Parent (N), Freeze_Node (Enclosing)); 9622 9623 else 9624 Insert_After 9625 (Freeze_Node (Par), Freeze_Node (Enclosing)); 9626 end if; 9627 end if; 9628 end; 9629 9630 else 9631 Insert_Freeze_Node_For_Instance (N, F_Node); 9632 end if; 9633 9634 else 9635 Insert_Freeze_Node_For_Instance (N, F_Node); 9636 end if; 9637 end if; 9638 9639 Set_Is_Frozen (Act_Id); 9640 Insert_Before (N, Act_Body); 9641 Mark_Rewrite_Insertion (Act_Body); 9642 end Install_Body; 9643 9644 ----------------------------- 9645 -- Install_Formal_Packages -- 9646 ----------------------------- 9647 9648 procedure Install_Formal_Packages (Par : Entity_Id) is 9649 E : Entity_Id; 9650 Gen : Entity_Id; 9651 Gen_E : Entity_Id := Empty; 9652 9653 begin 9654 E := First_Entity (Par); 9655 9656 -- If we are installing an instance parent, locate the formal packages 9657 -- of its generic parent. 9658 9659 if Is_Generic_Instance (Par) then 9660 Gen := Generic_Parent (Package_Specification (Par)); 9661 Gen_E := First_Entity (Gen); 9662 end if; 9663 9664 while Present (E) loop 9665 if Ekind (E) = E_Package 9666 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 9667 then 9668 -- If this is the renaming for the parent instance, done 9669 9670 if Renamed_Object (E) = Par then 9671 exit; 9672 9673 -- The visibility of a formal of an enclosing generic is already 9674 -- correct. 9675 9676 elsif Denotes_Formal_Package (E) then 9677 null; 9678 9679 elsif Present (Associated_Formal_Package (E)) then 9680 Check_Generic_Actuals (Renamed_Object (E), True); 9681 Set_Is_Hidden (E, False); 9682 9683 -- Find formal package in generic unit that corresponds to 9684 -- (instance of) formal package in instance. 9685 9686 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 9687 Next_Entity (Gen_E); 9688 end loop; 9689 9690 if Present (Gen_E) then 9691 Map_Formal_Package_Entities (Gen_E, E); 9692 end if; 9693 end if; 9694 end if; 9695 9696 Next_Entity (E); 9697 9698 if Present (Gen_E) then 9699 Next_Entity (Gen_E); 9700 end if; 9701 end loop; 9702 end Install_Formal_Packages; 9703 9704 -------------------- 9705 -- Install_Parent -- 9706 -------------------- 9707 9708 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 9709 Ancestors : constant Elist_Id := New_Elmt_List; 9710 S : constant Entity_Id := Current_Scope; 9711 Inst_Par : Entity_Id; 9712 First_Par : Entity_Id; 9713 Inst_Node : Node_Id; 9714 Gen_Par : Entity_Id; 9715 First_Gen : Entity_Id; 9716 Elmt : Elmt_Id; 9717 9718 procedure Install_Noninstance_Specs (Par : Entity_Id); 9719 -- Install the scopes of noninstance parent units ending with Par 9720 9721 procedure Install_Spec (Par : Entity_Id); 9722 -- The child unit is within the declarative part of the parent, so the 9723 -- declarations within the parent are immediately visible. 9724 9725 ------------------------------- 9726 -- Install_Noninstance_Specs -- 9727 ------------------------------- 9728 9729 procedure Install_Noninstance_Specs (Par : Entity_Id) is 9730 begin 9731 if Present (Par) 9732 and then Par /= Standard_Standard 9733 and then not In_Open_Scopes (Par) 9734 then 9735 Install_Noninstance_Specs (Scope (Par)); 9736 Install_Spec (Par); 9737 end if; 9738 end Install_Noninstance_Specs; 9739 9740 ------------------ 9741 -- Install_Spec -- 9742 ------------------ 9743 9744 procedure Install_Spec (Par : Entity_Id) is 9745 Spec : constant Node_Id := Package_Specification (Par); 9746 9747 begin 9748 -- If this parent of the child instance is a top-level unit, 9749 -- then record the unit and its visibility for later resetting in 9750 -- Remove_Parent. We exclude units that are generic instances, as we 9751 -- only want to record this information for the ultimate top-level 9752 -- noninstance parent (is that always correct???). 9753 9754 if Scope (Par) = Standard_Standard 9755 and then not Is_Generic_Instance (Par) 9756 then 9757 Parent_Unit_Visible := Is_Immediately_Visible (Par); 9758 Instance_Parent_Unit := Par; 9759 end if; 9760 9761 -- Open the parent scope and make it and its declarations visible. 9762 -- If this point is not within a body, then only the visible 9763 -- declarations should be made visible, and installation of the 9764 -- private declarations is deferred until the appropriate point 9765 -- within analysis of the spec being instantiated (see the handling 9766 -- of parent visibility in Analyze_Package_Specification). This is 9767 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 9768 -- private view problems that occur when compiling instantiations of 9769 -- a generic child of that package (Generic_Dispatching_Constructor). 9770 -- If the instance freezes a tagged type, inlinings of operations 9771 -- from Ada.Tags may need the full view of type Tag. If inlining took 9772 -- proper account of establishing visibility of inlined subprograms' 9773 -- parents then it should be possible to remove this 9774 -- special check. ??? 9775 9776 Push_Scope (Par); 9777 Set_Is_Immediately_Visible (Par); 9778 Install_Visible_Declarations (Par); 9779 Set_Use (Visible_Declarations (Spec)); 9780 9781 if In_Body or else Is_RTU (Par, Ada_Tags) then 9782 Install_Private_Declarations (Par); 9783 Set_Use (Private_Declarations (Spec)); 9784 end if; 9785 end Install_Spec; 9786 9787 -- Start of processing for Install_Parent 9788 9789 begin 9790 -- We need to install the parent instance to compile the instantiation 9791 -- of the child, but the child instance must appear in the current 9792 -- scope. Given that we cannot place the parent above the current scope 9793 -- in the scope stack, we duplicate the current scope and unstack both 9794 -- after the instantiation is complete. 9795 9796 -- If the parent is itself the instantiation of a child unit, we must 9797 -- also stack the instantiation of its parent, and so on. Each such 9798 -- ancestor is the prefix of the name in a prior instantiation. 9799 9800 -- If this is a nested instance, the parent unit itself resolves to 9801 -- a renaming of the parent instance, whose declaration we need. 9802 9803 -- Finally, the parent may be a generic (not an instance) when the 9804 -- child unit appears as a formal package. 9805 9806 Inst_Par := P; 9807 9808 if Present (Renamed_Entity (Inst_Par)) then 9809 Inst_Par := Renamed_Entity (Inst_Par); 9810 end if; 9811 9812 First_Par := Inst_Par; 9813 9814 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9815 9816 First_Gen := Gen_Par; 9817 9818 while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop 9819 9820 -- Load grandparent instance as well 9821 9822 Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); 9823 9824 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 9825 Inst_Par := Entity (Prefix (Name (Inst_Node))); 9826 9827 if Present (Renamed_Entity (Inst_Par)) then 9828 Inst_Par := Renamed_Entity (Inst_Par); 9829 end if; 9830 9831 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9832 9833 if Present (Gen_Par) then 9834 Prepend_Elmt (Inst_Par, Ancestors); 9835 9836 else 9837 -- Parent is not the name of an instantiation 9838 9839 Install_Noninstance_Specs (Inst_Par); 9840 exit; 9841 end if; 9842 9843 else 9844 -- Previous error 9845 9846 exit; 9847 end if; 9848 end loop; 9849 9850 if Present (First_Gen) then 9851 Append_Elmt (First_Par, Ancestors); 9852 else 9853 Install_Noninstance_Specs (First_Par); 9854 end if; 9855 9856 if not Is_Empty_Elmt_List (Ancestors) then 9857 Elmt := First_Elmt (Ancestors); 9858 while Present (Elmt) loop 9859 Install_Spec (Node (Elmt)); 9860 Install_Formal_Packages (Node (Elmt)); 9861 Next_Elmt (Elmt); 9862 end loop; 9863 end if; 9864 9865 if not In_Body then 9866 Push_Scope (S); 9867 end if; 9868 end Install_Parent; 9869 9870 ------------------------------- 9871 -- Install_Hidden_Primitives -- 9872 ------------------------------- 9873 9874 procedure Install_Hidden_Primitives 9875 (Prims_List : in out Elist_Id; 9876 Gen_T : Entity_Id; 9877 Act_T : Entity_Id) 9878 is 9879 Elmt : Elmt_Id; 9880 List : Elist_Id := No_Elist; 9881 Prim_G_Elmt : Elmt_Id; 9882 Prim_A_Elmt : Elmt_Id; 9883 Prim_G : Node_Id; 9884 Prim_A : Node_Id; 9885 9886 begin 9887 -- No action needed in case of serious errors because we cannot trust 9888 -- in the order of primitives 9889 9890 if Serious_Errors_Detected > 0 then 9891 return; 9892 9893 -- No action possible if we don't have available the list of primitive 9894 -- operations 9895 9896 elsif No (Gen_T) 9897 or else not Is_Record_Type (Gen_T) 9898 or else not Is_Tagged_Type (Gen_T) 9899 or else not Is_Record_Type (Act_T) 9900 or else not Is_Tagged_Type (Act_T) 9901 then 9902 return; 9903 9904 -- There is no need to handle interface types since their primitives 9905 -- cannot be hidden 9906 9907 elsif Is_Interface (Gen_T) then 9908 return; 9909 end if; 9910 9911 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 9912 9913 if not Is_Class_Wide_Type (Act_T) then 9914 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 9915 else 9916 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 9917 end if; 9918 9919 loop 9920 -- Skip predefined primitives in the generic formal 9921 9922 while Present (Prim_G_Elmt) 9923 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 9924 loop 9925 Next_Elmt (Prim_G_Elmt); 9926 end loop; 9927 9928 -- Skip predefined primitives in the generic actual 9929 9930 while Present (Prim_A_Elmt) 9931 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 9932 loop 9933 Next_Elmt (Prim_A_Elmt); 9934 end loop; 9935 9936 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 9937 9938 Prim_G := Node (Prim_G_Elmt); 9939 Prim_A := Node (Prim_A_Elmt); 9940 9941 -- There is no need to handle interface primitives because their 9942 -- primitives are not hidden 9943 9944 exit when Present (Interface_Alias (Prim_G)); 9945 9946 -- Here we install one hidden primitive 9947 9948 if Chars (Prim_G) /= Chars (Prim_A) 9949 and then Has_Suffix (Prim_A, 'P') 9950 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 9951 then 9952 Set_Chars (Prim_A, Chars (Prim_G)); 9953 Append_New_Elmt (Prim_A, To => List); 9954 end if; 9955 9956 Next_Elmt (Prim_A_Elmt); 9957 Next_Elmt (Prim_G_Elmt); 9958 end loop; 9959 9960 -- Append the elements to the list of temporarily visible primitives 9961 -- avoiding duplicates. 9962 9963 if Present (List) then 9964 if No (Prims_List) then 9965 Prims_List := New_Elmt_List; 9966 end if; 9967 9968 Elmt := First_Elmt (List); 9969 while Present (Elmt) loop 9970 Append_Unique_Elmt (Node (Elmt), Prims_List); 9971 Next_Elmt (Elmt); 9972 end loop; 9973 end if; 9974 end Install_Hidden_Primitives; 9975 9976 ------------------------------- 9977 -- Restore_Hidden_Primitives -- 9978 ------------------------------- 9979 9980 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 9981 Prim_Elmt : Elmt_Id; 9982 Prim : Node_Id; 9983 9984 begin 9985 if Prims_List /= No_Elist then 9986 Prim_Elmt := First_Elmt (Prims_List); 9987 while Present (Prim_Elmt) loop 9988 Prim := Node (Prim_Elmt); 9989 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 9990 Next_Elmt (Prim_Elmt); 9991 end loop; 9992 9993 Prims_List := No_Elist; 9994 end if; 9995 end Restore_Hidden_Primitives; 9996 9997 -------------------------------- 9998 -- Instantiate_Formal_Package -- 9999 -------------------------------- 10000 10001 function Instantiate_Formal_Package 10002 (Formal : Node_Id; 10003 Actual : Node_Id; 10004 Analyzed_Formal : Node_Id) return List_Id 10005 is 10006 Loc : constant Source_Ptr := Sloc (Actual); 10007 Actual_Pack : Entity_Id; 10008 Formal_Pack : Entity_Id; 10009 Gen_Parent : Entity_Id; 10010 Decls : List_Id; 10011 Nod : Node_Id; 10012 Parent_Spec : Node_Id; 10013 10014 procedure Find_Matching_Actual 10015 (F : Node_Id; 10016 Act : in out Entity_Id); 10017 -- We need to associate each formal entity in the formal package with 10018 -- the corresponding entity in the actual package. The actual package 10019 -- has been analyzed and possibly expanded, and as a result there is 10020 -- no one-to-one correspondence between the two lists (for example, 10021 -- the actual may include subtypes, itypes, and inherited primitive 10022 -- operations, interspersed among the renaming declarations for the 10023 -- actuals). We retrieve the corresponding actual by name because each 10024 -- actual has the same name as the formal, and they do appear in the 10025 -- same order. 10026 10027 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 10028 -- Retrieve entity of defining entity of generic formal parameter. 10029 -- Only the declarations of formals need to be considered when 10030 -- linking them to actuals, but the declarative list may include 10031 -- internal entities generated during analysis, and those are ignored. 10032 10033 procedure Match_Formal_Entity 10034 (Formal_Node : Node_Id; 10035 Formal_Ent : Entity_Id; 10036 Actual_Ent : Entity_Id); 10037 -- Associates the formal entity with the actual. In the case where 10038 -- Formal_Ent is a formal package, this procedure iterates through all 10039 -- of its formals and enters associations between the actuals occurring 10040 -- in the formal package's corresponding actual package (given by 10041 -- Actual_Ent) and the formal package's formal parameters. This 10042 -- procedure recurses if any of the parameters is itself a package. 10043 10044 function Is_Instance_Of 10045 (Act_Spec : Entity_Id; 10046 Gen_Anc : Entity_Id) return Boolean; 10047 -- The actual can be an instantiation of a generic within another 10048 -- instance, in which case there is no direct link from it to the 10049 -- original generic ancestor. In that case, we recognize that the 10050 -- ultimate ancestor is the same by examining names and scopes. 10051 10052 procedure Process_Nested_Formal (Formal : Entity_Id); 10053 -- If the current formal is declared with a box, its own formals are 10054 -- visible in the instance, as they were in the generic, and their 10055 -- Hidden flag must be reset. If some of these formals are themselves 10056 -- packages declared with a box, the processing must be recursive. 10057 10058 -------------------------- 10059 -- Find_Matching_Actual -- 10060 -------------------------- 10061 10062 procedure Find_Matching_Actual 10063 (F : Node_Id; 10064 Act : in out Entity_Id) 10065 is 10066 Formal_Ent : Entity_Id; 10067 10068 begin 10069 case Nkind (Original_Node (F)) is 10070 when N_Formal_Object_Declaration 10071 | N_Formal_Type_Declaration 10072 => 10073 Formal_Ent := Defining_Identifier (F); 10074 10075 while Chars (Act) /= Chars (Formal_Ent) loop 10076 Next_Entity (Act); 10077 end loop; 10078 10079 when N_Formal_Package_Declaration 10080 | N_Formal_Subprogram_Declaration 10081 | N_Generic_Package_Declaration 10082 | N_Package_Declaration 10083 => 10084 Formal_Ent := Defining_Entity (F); 10085 10086 while Chars (Act) /= Chars (Formal_Ent) loop 10087 Next_Entity (Act); 10088 end loop; 10089 10090 when others => 10091 raise Program_Error; 10092 end case; 10093 end Find_Matching_Actual; 10094 10095 ------------------------- 10096 -- Match_Formal_Entity -- 10097 ------------------------- 10098 10099 procedure Match_Formal_Entity 10100 (Formal_Node : Node_Id; 10101 Formal_Ent : Entity_Id; 10102 Actual_Ent : Entity_Id) 10103 is 10104 Act_Pkg : Entity_Id; 10105 10106 begin 10107 Set_Instance_Of (Formal_Ent, Actual_Ent); 10108 10109 if Ekind (Actual_Ent) = E_Package then 10110 10111 -- Record associations for each parameter 10112 10113 Act_Pkg := Actual_Ent; 10114 10115 declare 10116 A_Ent : Entity_Id := First_Entity (Act_Pkg); 10117 F_Ent : Entity_Id; 10118 F_Node : Node_Id; 10119 10120 Gen_Decl : Node_Id; 10121 Formals : List_Id; 10122 Actual : Entity_Id; 10123 10124 begin 10125 -- Retrieve the actual given in the formal package declaration 10126 10127 Actual := Entity (Name (Original_Node (Formal_Node))); 10128 10129 -- The actual in the formal package declaration may be a 10130 -- renamed generic package, in which case we want to retrieve 10131 -- the original generic in order to traverse its formal part. 10132 10133 if Present (Renamed_Entity (Actual)) then 10134 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 10135 else 10136 Gen_Decl := Unit_Declaration_Node (Actual); 10137 end if; 10138 10139 Formals := Generic_Formal_Declarations (Gen_Decl); 10140 10141 if Present (Formals) then 10142 F_Node := First_Non_Pragma (Formals); 10143 else 10144 F_Node := Empty; 10145 end if; 10146 10147 while Present (A_Ent) 10148 and then Present (F_Node) 10149 and then A_Ent /= First_Private_Entity (Act_Pkg) 10150 loop 10151 F_Ent := Get_Formal_Entity (F_Node); 10152 10153 if Present (F_Ent) then 10154 10155 -- This is a formal of the original package. Record 10156 -- association and recurse. 10157 10158 Find_Matching_Actual (F_Node, A_Ent); 10159 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 10160 Next_Entity (A_Ent); 10161 end if; 10162 10163 Next_Non_Pragma (F_Node); 10164 end loop; 10165 end; 10166 end if; 10167 end Match_Formal_Entity; 10168 10169 ----------------------- 10170 -- Get_Formal_Entity -- 10171 ----------------------- 10172 10173 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 10174 Kind : constant Node_Kind := Nkind (Original_Node (N)); 10175 begin 10176 case Kind is 10177 when N_Formal_Object_Declaration => 10178 return Defining_Identifier (N); 10179 10180 when N_Formal_Type_Declaration => 10181 return Defining_Identifier (N); 10182 10183 when N_Formal_Subprogram_Declaration => 10184 return Defining_Unit_Name (Specification (N)); 10185 10186 when N_Formal_Package_Declaration => 10187 return Defining_Identifier (Original_Node (N)); 10188 10189 when N_Generic_Package_Declaration => 10190 return Defining_Identifier (Original_Node (N)); 10191 10192 -- All other declarations are introduced by semantic analysis and 10193 -- have no match in the actual. 10194 10195 when others => 10196 return Empty; 10197 end case; 10198 end Get_Formal_Entity; 10199 10200 -------------------- 10201 -- Is_Instance_Of -- 10202 -------------------- 10203 10204 function Is_Instance_Of 10205 (Act_Spec : Entity_Id; 10206 Gen_Anc : Entity_Id) return Boolean 10207 is 10208 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 10209 10210 begin 10211 if No (Gen_Par) then 10212 return False; 10213 10214 -- Simplest case: the generic parent of the actual is the formal 10215 10216 elsif Gen_Par = Gen_Anc then 10217 return True; 10218 10219 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 10220 return False; 10221 10222 -- The actual may be obtained through several instantiations. Its 10223 -- scope must itself be an instance of a generic declared in the 10224 -- same scope as the formal. Any other case is detected above. 10225 10226 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 10227 return False; 10228 10229 else 10230 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 10231 end if; 10232 end Is_Instance_Of; 10233 10234 --------------------------- 10235 -- Process_Nested_Formal -- 10236 --------------------------- 10237 10238 procedure Process_Nested_Formal (Formal : Entity_Id) is 10239 Ent : Entity_Id; 10240 10241 begin 10242 if Present (Associated_Formal_Package (Formal)) 10243 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 10244 then 10245 Ent := First_Entity (Formal); 10246 while Present (Ent) loop 10247 Set_Is_Hidden (Ent, False); 10248 Set_Is_Visible_Formal (Ent); 10249 Set_Is_Potentially_Use_Visible 10250 (Ent, Is_Potentially_Use_Visible (Formal)); 10251 10252 if Ekind (Ent) = E_Package then 10253 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 10254 Process_Nested_Formal (Ent); 10255 end if; 10256 10257 Next_Entity (Ent); 10258 end loop; 10259 end if; 10260 end Process_Nested_Formal; 10261 10262 -- Start of processing for Instantiate_Formal_Package 10263 10264 begin 10265 Analyze (Actual); 10266 10267 if not Is_Entity_Name (Actual) 10268 or else Ekind (Entity (Actual)) /= E_Package 10269 then 10270 Error_Msg_N 10271 ("expect package instance to instantiate formal", Actual); 10272 Abandon_Instantiation (Actual); 10273 raise Program_Error; 10274 10275 else 10276 Actual_Pack := Entity (Actual); 10277 Set_Is_Instantiated (Actual_Pack); 10278 10279 -- The actual may be a renamed package, or an outer generic formal 10280 -- package whose instantiation is converted into a renaming. 10281 10282 if Present (Renamed_Object (Actual_Pack)) then 10283 Actual_Pack := Renamed_Object (Actual_Pack); 10284 end if; 10285 10286 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 10287 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 10288 Formal_Pack := Defining_Identifier (Analyzed_Formal); 10289 else 10290 Gen_Parent := 10291 Generic_Parent (Specification (Analyzed_Formal)); 10292 Formal_Pack := 10293 Defining_Unit_Name (Specification (Analyzed_Formal)); 10294 end if; 10295 10296 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 10297 Parent_Spec := Package_Specification (Actual_Pack); 10298 else 10299 Parent_Spec := Parent (Actual_Pack); 10300 end if; 10301 10302 if Gen_Parent = Any_Id then 10303 Error_Msg_N 10304 ("previous error in declaration of formal package", Actual); 10305 Abandon_Instantiation (Actual); 10306 10307 elsif 10308 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) 10309 then 10310 null; 10311 10312 else 10313 Error_Msg_NE 10314 ("actual parameter must be instance of&", Actual, Gen_Parent); 10315 Abandon_Instantiation (Actual); 10316 end if; 10317 10318 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 10319 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 10320 10321 Nod := 10322 Make_Package_Renaming_Declaration (Loc, 10323 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 10324 Name => New_Occurrence_Of (Actual_Pack, Loc)); 10325 10326 Set_Associated_Formal_Package 10327 (Defining_Unit_Name (Nod), Defining_Identifier (Formal)); 10328 Decls := New_List (Nod); 10329 10330 -- If the formal F has a box, then the generic declarations are 10331 -- visible in the generic G. In an instance of G, the corresponding 10332 -- entities in the actual for F (which are the actuals for the 10333 -- instantiation of the generic that F denotes) must also be made 10334 -- visible for analysis of the current instance. On exit from the 10335 -- current instance, those entities are made private again. If the 10336 -- actual is currently in use, these entities are also use-visible. 10337 10338 -- The loop through the actual entities also steps through the formal 10339 -- entities and enters associations from formals to actuals into the 10340 -- renaming map. This is necessary to properly handle checking of 10341 -- actual parameter associations for later formals that depend on 10342 -- actuals declared in the formal package. 10343 10344 -- In Ada 2005, partial parameterization requires that we make 10345 -- visible the actuals corresponding to formals that were defaulted 10346 -- in the formal package. There formals are identified because they 10347 -- remain formal generics within the formal package, rather than 10348 -- being renamings of the actuals supplied. 10349 10350 declare 10351 Gen_Decl : constant Node_Id := 10352 Unit_Declaration_Node (Gen_Parent); 10353 Formals : constant List_Id := 10354 Generic_Formal_Declarations (Gen_Decl); 10355 10356 Actual_Ent : Entity_Id; 10357 Actual_Of_Formal : Node_Id; 10358 Formal_Node : Node_Id; 10359 Formal_Ent : Entity_Id; 10360 10361 begin 10362 if Present (Formals) then 10363 Formal_Node := First_Non_Pragma (Formals); 10364 else 10365 Formal_Node := Empty; 10366 end if; 10367 10368 Actual_Ent := First_Entity (Actual_Pack); 10369 Actual_Of_Formal := 10370 First (Visible_Declarations (Specification (Analyzed_Formal))); 10371 while Present (Actual_Ent) 10372 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10373 loop 10374 if Present (Formal_Node) then 10375 Formal_Ent := Get_Formal_Entity (Formal_Node); 10376 10377 if Present (Formal_Ent) then 10378 Find_Matching_Actual (Formal_Node, Actual_Ent); 10379 Match_Formal_Entity (Formal_Node, Formal_Ent, Actual_Ent); 10380 10381 -- We iterate at the same time over the actuals of the 10382 -- local package created for the formal, to determine 10383 -- which one of the formals of the original generic were 10384 -- defaulted in the formal. The corresponding actual 10385 -- entities are visible in the enclosing instance. 10386 10387 if Box_Present (Formal) 10388 or else 10389 (Present (Actual_Of_Formal) 10390 and then 10391 Is_Generic_Formal 10392 (Get_Formal_Entity (Actual_Of_Formal))) 10393 then 10394 Set_Is_Hidden (Actual_Ent, False); 10395 Set_Is_Visible_Formal (Actual_Ent); 10396 Set_Is_Potentially_Use_Visible 10397 (Actual_Ent, In_Use (Actual_Pack)); 10398 10399 if Ekind (Actual_Ent) = E_Package then 10400 Process_Nested_Formal (Actual_Ent); 10401 end if; 10402 10403 else 10404 Set_Is_Hidden (Actual_Ent); 10405 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 10406 end if; 10407 end if; 10408 10409 Next_Non_Pragma (Formal_Node); 10410 Next (Actual_Of_Formal); 10411 10412 else 10413 -- No further formals to match, but the generic part may 10414 -- contain inherited operation that are not hidden in the 10415 -- enclosing instance. 10416 10417 Next_Entity (Actual_Ent); 10418 end if; 10419 end loop; 10420 10421 -- Inherited subprograms generated by formal derived types are 10422 -- also visible if the types are. 10423 10424 Actual_Ent := First_Entity (Actual_Pack); 10425 while Present (Actual_Ent) 10426 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10427 loop 10428 if Is_Overloadable (Actual_Ent) 10429 and then 10430 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 10431 and then 10432 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 10433 then 10434 Set_Is_Hidden (Actual_Ent, False); 10435 Set_Is_Potentially_Use_Visible 10436 (Actual_Ent, In_Use (Actual_Pack)); 10437 end if; 10438 10439 Next_Entity (Actual_Ent); 10440 end loop; 10441 end; 10442 10443 -- If the formal is not declared with a box, reanalyze it as an 10444 -- abbreviated instantiation, to verify the matching rules of 12.7. 10445 -- The actual checks are performed after the generic associations 10446 -- have been analyzed, to guarantee the same visibility for this 10447 -- instantiation and for the actuals. 10448 10449 -- In Ada 2005, the generic associations for the formal can include 10450 -- defaulted parameters. These are ignored during check. This 10451 -- internal instantiation is removed from the tree after conformance 10452 -- checking, because it contains formal declarations for those 10453 -- defaulted parameters, and those should not reach the back-end. 10454 10455 if not Box_Present (Formal) then 10456 declare 10457 I_Pack : constant Entity_Id := 10458 Make_Temporary (Sloc (Actual), 'P'); 10459 10460 begin 10461 Set_Is_Internal (I_Pack); 10462 10463 Append_To (Decls, 10464 Make_Package_Instantiation (Sloc (Actual), 10465 Defining_Unit_Name => I_Pack, 10466 Name => 10467 New_Occurrence_Of 10468 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 10469 Generic_Associations => Generic_Associations (Formal))); 10470 end; 10471 end if; 10472 10473 return Decls; 10474 end if; 10475 end Instantiate_Formal_Package; 10476 10477 ----------------------------------- 10478 -- Instantiate_Formal_Subprogram -- 10479 ----------------------------------- 10480 10481 function Instantiate_Formal_Subprogram 10482 (Formal : Node_Id; 10483 Actual : Node_Id; 10484 Analyzed_Formal : Node_Id) return Node_Id 10485 is 10486 Analyzed_S : constant Entity_Id := 10487 Defining_Unit_Name (Specification (Analyzed_Formal)); 10488 Formal_Sub : constant Entity_Id := 10489 Defining_Unit_Name (Specification (Formal)); 10490 10491 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 10492 -- If the generic is a child unit, the parent has been installed on the 10493 -- scope stack, but a default subprogram cannot resolve to something 10494 -- on the parent because that parent is not really part of the visible 10495 -- context (it is there to resolve explicit local entities). If the 10496 -- default has resolved in this way, we remove the entity from immediate 10497 -- visibility and analyze the node again to emit an error message or 10498 -- find another visible candidate. 10499 10500 procedure Valid_Actual_Subprogram (Act : Node_Id); 10501 -- Perform legality check and raise exception on failure 10502 10503 ----------------------- 10504 -- From_Parent_Scope -- 10505 ----------------------- 10506 10507 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 10508 Gen_Scope : Node_Id; 10509 10510 begin 10511 Gen_Scope := Scope (Analyzed_S); 10512 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 10513 if Scope (Subp) = Scope (Gen_Scope) then 10514 return True; 10515 end if; 10516 10517 Gen_Scope := Scope (Gen_Scope); 10518 end loop; 10519 10520 return False; 10521 end From_Parent_Scope; 10522 10523 ----------------------------- 10524 -- Valid_Actual_Subprogram -- 10525 ----------------------------- 10526 10527 procedure Valid_Actual_Subprogram (Act : Node_Id) is 10528 Act_E : Entity_Id; 10529 10530 begin 10531 if Is_Entity_Name (Act) then 10532 Act_E := Entity (Act); 10533 10534 elsif Nkind (Act) = N_Selected_Component 10535 and then Is_Entity_Name (Selector_Name (Act)) 10536 then 10537 Act_E := Entity (Selector_Name (Act)); 10538 10539 else 10540 Act_E := Empty; 10541 end if; 10542 10543 if (Present (Act_E) and then Is_Overloadable (Act_E)) 10544 or else Nkind_In (Act, N_Attribute_Reference, 10545 N_Indexed_Component, 10546 N_Character_Literal, 10547 N_Explicit_Dereference) 10548 then 10549 return; 10550 end if; 10551 10552 Error_Msg_NE 10553 ("expect subprogram or entry name in instantiation of &", 10554 Instantiation_Node, Formal_Sub); 10555 Abandon_Instantiation (Instantiation_Node); 10556 end Valid_Actual_Subprogram; 10557 10558 -- Local variables 10559 10560 Decl_Node : Node_Id; 10561 Loc : Source_Ptr; 10562 Nam : Node_Id; 10563 New_Spec : Node_Id; 10564 New_Subp : Entity_Id; 10565 10566 -- Start of processing for Instantiate_Formal_Subprogram 10567 10568 begin 10569 New_Spec := New_Copy_Tree (Specification (Formal)); 10570 10571 -- The tree copy has created the proper instantiation sloc for the 10572 -- new specification. Use this location for all other constructed 10573 -- declarations. 10574 10575 Loc := Sloc (Defining_Unit_Name (New_Spec)); 10576 10577 -- Create new entity for the actual (New_Copy_Tree does not), and 10578 -- indicate that it is an actual. 10579 10580 New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); 10581 Set_Ekind (New_Subp, Ekind (Analyzed_S)); 10582 Set_Is_Generic_Actual_Subprogram (New_Subp); 10583 Set_Defining_Unit_Name (New_Spec, New_Subp); 10584 10585 -- Create new entities for the each of the formals in the specification 10586 -- of the renaming declaration built for the actual. 10587 10588 if Present (Parameter_Specifications (New_Spec)) then 10589 declare 10590 F : Node_Id; 10591 F_Id : Entity_Id; 10592 10593 begin 10594 F := First (Parameter_Specifications (New_Spec)); 10595 while Present (F) loop 10596 F_Id := Defining_Identifier (F); 10597 10598 Set_Defining_Identifier (F, 10599 Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id))); 10600 Next (F); 10601 end loop; 10602 end; 10603 end if; 10604 10605 -- Find entity of actual. If the actual is an attribute reference, it 10606 -- cannot be resolved here (its formal is missing) but is handled 10607 -- instead in Attribute_Renaming. If the actual is overloaded, it is 10608 -- fully resolved subsequently, when the renaming declaration for the 10609 -- formal is analyzed. If it is an explicit dereference, resolve the 10610 -- prefix but not the actual itself, to prevent interpretation as call. 10611 10612 if Present (Actual) then 10613 Loc := Sloc (Actual); 10614 Set_Sloc (New_Spec, Loc); 10615 10616 if Nkind (Actual) = N_Operator_Symbol then 10617 Find_Direct_Name (Actual); 10618 10619 elsif Nkind (Actual) = N_Explicit_Dereference then 10620 Analyze (Prefix (Actual)); 10621 10622 elsif Nkind (Actual) /= N_Attribute_Reference then 10623 Analyze (Actual); 10624 end if; 10625 10626 Valid_Actual_Subprogram (Actual); 10627 Nam := Actual; 10628 10629 elsif Present (Default_Name (Formal)) then 10630 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 10631 N_Selected_Component, 10632 N_Indexed_Component, 10633 N_Character_Literal) 10634 and then Present (Entity (Default_Name (Formal))) 10635 then 10636 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 10637 else 10638 Nam := New_Copy (Default_Name (Formal)); 10639 Set_Sloc (Nam, Loc); 10640 end if; 10641 10642 elsif Box_Present (Formal) then 10643 10644 -- Actual is resolved at the point of instantiation. Create an 10645 -- identifier or operator with the same name as the formal. 10646 10647 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 10648 Nam := 10649 Make_Operator_Symbol (Loc, 10650 Chars => Chars (Formal_Sub), 10651 Strval => No_String); 10652 else 10653 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 10654 end if; 10655 10656 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 10657 and then Null_Present (Specification (Formal)) 10658 then 10659 -- Generate null body for procedure, for use in the instance 10660 10661 Decl_Node := 10662 Make_Subprogram_Body (Loc, 10663 Specification => New_Spec, 10664 Declarations => New_List, 10665 Handled_Statement_Sequence => 10666 Make_Handled_Sequence_Of_Statements (Loc, 10667 Statements => New_List (Make_Null_Statement (Loc)))); 10668 10669 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 10670 return Decl_Node; 10671 10672 else 10673 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 10674 Error_Msg_NE 10675 ("missing actual&", Instantiation_Node, Formal_Sub); 10676 Error_Msg_NE 10677 ("\in instantiation of & declared#", 10678 Instantiation_Node, Scope (Analyzed_S)); 10679 Abandon_Instantiation (Instantiation_Node); 10680 end if; 10681 10682 Decl_Node := 10683 Make_Subprogram_Renaming_Declaration (Loc, 10684 Specification => New_Spec, 10685 Name => Nam); 10686 10687 -- If we do not have an actual and the formal specified <> then set to 10688 -- get proper default. 10689 10690 if No (Actual) and then Box_Present (Formal) then 10691 Set_From_Default (Decl_Node); 10692 end if; 10693 10694 -- Gather possible interpretations for the actual before analyzing the 10695 -- instance. If overloaded, it will be resolved when analyzing the 10696 -- renaming declaration. 10697 10698 if Box_Present (Formal) and then No (Actual) then 10699 Analyze (Nam); 10700 10701 if Is_Child_Unit (Scope (Analyzed_S)) 10702 and then Present (Entity (Nam)) 10703 then 10704 if not Is_Overloaded (Nam) then 10705 if From_Parent_Scope (Entity (Nam)) then 10706 Set_Is_Immediately_Visible (Entity (Nam), False); 10707 Set_Entity (Nam, Empty); 10708 Set_Etype (Nam, Empty); 10709 10710 Analyze (Nam); 10711 Set_Is_Immediately_Visible (Entity (Nam)); 10712 end if; 10713 10714 else 10715 declare 10716 I : Interp_Index; 10717 It : Interp; 10718 10719 begin 10720 Get_First_Interp (Nam, I, It); 10721 while Present (It.Nam) loop 10722 if From_Parent_Scope (It.Nam) then 10723 Remove_Interp (I); 10724 end if; 10725 10726 Get_Next_Interp (I, It); 10727 end loop; 10728 end; 10729 end if; 10730 end if; 10731 end if; 10732 10733 -- The generic instantiation freezes the actual. This can only be done 10734 -- once the actual is resolved, in the analysis of the renaming 10735 -- declaration. To make the formal subprogram entity available, we set 10736 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 10737 -- This is also needed in Analyze_Subprogram_Renaming for the processing 10738 -- of formal abstract subprograms. 10739 10740 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 10741 10742 -- We cannot analyze the renaming declaration, and thus find the actual, 10743 -- until all the actuals are assembled in the instance. For subsequent 10744 -- checks of other actuals, indicate the node that will hold the 10745 -- instance of this formal. 10746 10747 Set_Instance_Of (Analyzed_S, Nam); 10748 10749 if Nkind (Actual) = N_Selected_Component 10750 and then Is_Task_Type (Etype (Prefix (Actual))) 10751 and then not Is_Frozen (Etype (Prefix (Actual))) 10752 then 10753 -- The renaming declaration will create a body, which must appear 10754 -- outside of the instantiation, We move the renaming declaration 10755 -- out of the instance, and create an additional renaming inside, 10756 -- to prevent freezing anomalies. 10757 10758 declare 10759 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 10760 10761 begin 10762 Set_Defining_Unit_Name (New_Spec, Anon_Id); 10763 Insert_Before (Instantiation_Node, Decl_Node); 10764 Analyze (Decl_Node); 10765 10766 -- Now create renaming within the instance 10767 10768 Decl_Node := 10769 Make_Subprogram_Renaming_Declaration (Loc, 10770 Specification => New_Copy_Tree (New_Spec), 10771 Name => New_Occurrence_Of (Anon_Id, Loc)); 10772 10773 Set_Defining_Unit_Name (Specification (Decl_Node), 10774 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 10775 end; 10776 end if; 10777 10778 return Decl_Node; 10779 end Instantiate_Formal_Subprogram; 10780 10781 ------------------------ 10782 -- Instantiate_Object -- 10783 ------------------------ 10784 10785 function Instantiate_Object 10786 (Formal : Node_Id; 10787 Actual : Node_Id; 10788 Analyzed_Formal : Node_Id) return List_Id 10789 is 10790 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 10791 A_Gen_Obj : constant Entity_Id := 10792 Defining_Identifier (Analyzed_Formal); 10793 Acc_Def : Node_Id := Empty; 10794 Act_Assoc : constant Node_Id := Parent (Actual); 10795 Actual_Decl : Node_Id := Empty; 10796 Decl_Node : Node_Id; 10797 Def : Node_Id; 10798 Ftyp : Entity_Id; 10799 List : constant List_Id := New_List; 10800 Loc : constant Source_Ptr := Sloc (Actual); 10801 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 10802 Subt_Decl : Node_Id := Empty; 10803 Subt_Mark : Node_Id := Empty; 10804 10805 function Copy_Access_Def return Node_Id; 10806 -- If formal is an anonymous access, copy access definition of formal 10807 -- for generated object declaration. 10808 10809 --------------------- 10810 -- Copy_Access_Def -- 10811 --------------------- 10812 10813 function Copy_Access_Def return Node_Id is 10814 begin 10815 Def := New_Copy_Tree (Acc_Def); 10816 10817 -- In addition, if formal is an access to subprogram we need to 10818 -- generate new formals for the signature of the default, so that 10819 -- the tree is properly formatted for ASIS use. 10820 10821 if Present (Access_To_Subprogram_Definition (Acc_Def)) then 10822 declare 10823 Par_Spec : Node_Id; 10824 begin 10825 Par_Spec := 10826 First (Parameter_Specifications 10827 (Access_To_Subprogram_Definition (Def))); 10828 while Present (Par_Spec) loop 10829 Set_Defining_Identifier (Par_Spec, 10830 Make_Defining_Identifier (Sloc (Acc_Def), 10831 Chars => Chars (Defining_Identifier (Par_Spec)))); 10832 Next (Par_Spec); 10833 end loop; 10834 end; 10835 end if; 10836 10837 return Def; 10838 end Copy_Access_Def; 10839 10840 -- Start of processing for Instantiate_Object 10841 10842 begin 10843 -- Formal may be an anonymous access 10844 10845 if Present (Subtype_Mark (Formal)) then 10846 Subt_Mark := Subtype_Mark (Formal); 10847 else 10848 Check_Access_Definition (Formal); 10849 Acc_Def := Access_Definition (Formal); 10850 end if; 10851 10852 -- Sloc for error message on missing actual 10853 10854 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 10855 10856 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 10857 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 10858 end if; 10859 10860 Set_Parent (List, Parent (Actual)); 10861 10862 -- OUT present 10863 10864 if Out_Present (Formal) then 10865 10866 -- An IN OUT generic actual must be a name. The instantiation is a 10867 -- renaming declaration. The actual is the name being renamed. We 10868 -- use the actual directly, rather than a copy, because it is not 10869 -- used further in the list of actuals, and because a copy or a use 10870 -- of relocate_node is incorrect if the instance is nested within a 10871 -- generic. In order to simplify ASIS searches, the Generic_Parent 10872 -- field links the declaration to the generic association. 10873 10874 if No (Actual) then 10875 Error_Msg_NE 10876 ("missing actual &", 10877 Instantiation_Node, Gen_Obj); 10878 Error_Msg_NE 10879 ("\in instantiation of & declared#", 10880 Instantiation_Node, Scope (A_Gen_Obj)); 10881 Abandon_Instantiation (Instantiation_Node); 10882 end if; 10883 10884 if Present (Subt_Mark) then 10885 Decl_Node := 10886 Make_Object_Renaming_Declaration (Loc, 10887 Defining_Identifier => New_Copy (Gen_Obj), 10888 Subtype_Mark => New_Copy_Tree (Subt_Mark), 10889 Name => Actual); 10890 10891 else pragma Assert (Present (Acc_Def)); 10892 Decl_Node := 10893 Make_Object_Renaming_Declaration (Loc, 10894 Defining_Identifier => New_Copy (Gen_Obj), 10895 Access_Definition => New_Copy_Tree (Acc_Def), 10896 Name => Actual); 10897 end if; 10898 10899 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 10900 10901 -- The analysis of the actual may produce Insert_Action nodes, so 10902 -- the declaration must have a context in which to attach them. 10903 10904 Append (Decl_Node, List); 10905 Analyze (Actual); 10906 10907 -- Return if the analysis of the actual reported some error 10908 10909 if Etype (Actual) = Any_Type then 10910 return List; 10911 end if; 10912 10913 -- This check is performed here because Analyze_Object_Renaming will 10914 -- not check it when Comes_From_Source is False. Note though that the 10915 -- check for the actual being the name of an object will be performed 10916 -- in Analyze_Object_Renaming. 10917 10918 if Is_Object_Reference (Actual) 10919 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 10920 then 10921 Error_Msg_N 10922 ("illegal discriminant-dependent component for in out parameter", 10923 Actual); 10924 end if; 10925 10926 -- The actual has to be resolved in order to check that it is a 10927 -- variable (due to cases such as F (1), where F returns access to 10928 -- an array, and for overloaded prefixes). 10929 10930 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 10931 10932 -- If the type of the formal is not itself a formal, and the current 10933 -- unit is a child unit, the formal type must be declared in a 10934 -- parent, and must be retrieved by visibility. 10935 10936 if Ftyp = Orig_Ftyp 10937 and then Is_Generic_Unit (Scope (Ftyp)) 10938 and then Is_Child_Unit (Scope (A_Gen_Obj)) 10939 then 10940 declare 10941 Temp : constant Node_Id := 10942 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 10943 begin 10944 Set_Entity (Temp, Empty); 10945 Find_Type (Temp); 10946 Ftyp := Entity (Temp); 10947 end; 10948 end if; 10949 10950 if Is_Private_Type (Ftyp) 10951 and then not Is_Private_Type (Etype (Actual)) 10952 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 10953 or else Base_Type (Etype (Actual)) = Ftyp) 10954 then 10955 -- If the actual has the type of the full view of the formal, or 10956 -- else a non-private subtype of the formal, then the visibility 10957 -- of the formal type has changed. Add to the actuals a subtype 10958 -- declaration that will force the exchange of views in the body 10959 -- of the instance as well. 10960 10961 Subt_Decl := 10962 Make_Subtype_Declaration (Loc, 10963 Defining_Identifier => Make_Temporary (Loc, 'P'), 10964 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 10965 10966 Prepend (Subt_Decl, List); 10967 10968 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 10969 Exchange_Declarations (Ftyp); 10970 end if; 10971 10972 Resolve (Actual, Ftyp); 10973 10974 if not Denotes_Variable (Actual) then 10975 Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj); 10976 10977 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 10978 10979 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 10980 -- the type of the actual shall resolve to a specific anonymous 10981 -- access type. 10982 10983 if Ada_Version < Ada_2005 10984 or else Ekind (Base_Type (Ftyp)) /= 10985 E_Anonymous_Access_Type 10986 or else Ekind (Base_Type (Etype (Actual))) /= 10987 E_Anonymous_Access_Type 10988 then 10989 Error_Msg_NE 10990 ("type of actual does not match type of&", Actual, Gen_Obj); 10991 end if; 10992 end if; 10993 10994 Note_Possible_Modification (Actual, Sure => True); 10995 10996 -- Check for instantiation of atomic/volatile actual for 10997 -- non-atomic/volatile formal (RM C.6 (12)). 10998 10999 if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then 11000 Error_Msg_N 11001 ("cannot instantiate non-atomic formal object " 11002 & "with atomic actual", Actual); 11003 11004 elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) 11005 then 11006 Error_Msg_N 11007 ("cannot instantiate non-volatile formal object " 11008 & "with volatile actual", Actual); 11009 end if; 11010 11011 -- Formal in-parameter 11012 11013 else 11014 -- The instantiation of a generic formal in-parameter is constant 11015 -- declaration. The actual is the expression for that declaration. 11016 -- Its type is a full copy of the type of the formal. This may be 11017 -- an access to subprogram, for which we need to generate entities 11018 -- for the formals in the new signature. 11019 11020 if Present (Actual) then 11021 if Present (Subt_Mark) then 11022 Def := New_Copy_Tree (Subt_Mark); 11023 else pragma Assert (Present (Acc_Def)); 11024 Def := Copy_Access_Def; 11025 end if; 11026 11027 Decl_Node := 11028 Make_Object_Declaration (Loc, 11029 Defining_Identifier => New_Copy (Gen_Obj), 11030 Constant_Present => True, 11031 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11032 Object_Definition => Def, 11033 Expression => Actual); 11034 11035 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 11036 11037 -- A generic formal object of a tagged type is defined to be 11038 -- aliased so the new constant must also be treated as aliased. 11039 11040 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 11041 Set_Aliased_Present (Decl_Node); 11042 end if; 11043 11044 Append (Decl_Node, List); 11045 11046 -- No need to repeat (pre-)analysis of some expression nodes 11047 -- already handled in Preanalyze_Actuals. 11048 11049 if Nkind (Actual) /= N_Allocator then 11050 Analyze (Actual); 11051 11052 -- Return if the analysis of the actual reported some error 11053 11054 if Etype (Actual) = Any_Type then 11055 return List; 11056 end if; 11057 end if; 11058 11059 declare 11060 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 11061 Typ : Entity_Id; 11062 11063 begin 11064 Typ := Get_Instance_Of (Formal_Type); 11065 11066 -- If the actual appears in the current or an enclosing scope, 11067 -- use its type directly. This is relevant if it has an actual 11068 -- subtype that is distinct from its nominal one. This cannot 11069 -- be done in general because the type of the actual may 11070 -- depend on other actuals, and only be fully determined when 11071 -- the enclosing instance is analyzed. 11072 11073 if Present (Etype (Actual)) 11074 and then Is_Constr_Subt_For_U_Nominal (Etype (Actual)) 11075 then 11076 Freeze_Before (Instantiation_Node, Etype (Actual)); 11077 else 11078 Freeze_Before (Instantiation_Node, Typ); 11079 end if; 11080 11081 -- If the actual is an aggregate, perform name resolution on 11082 -- its components (the analysis of an aggregate does not do it) 11083 -- to capture local names that may be hidden if the generic is 11084 -- a child unit. 11085 11086 if Nkind (Actual) = N_Aggregate then 11087 Preanalyze_And_Resolve (Actual, Typ); 11088 end if; 11089 11090 if Is_Limited_Type (Typ) 11091 and then not OK_For_Limited_Init (Typ, Actual) 11092 then 11093 Error_Msg_N 11094 ("initialization not allowed for limited types", Actual); 11095 Explain_Limited_Type (Typ, Actual); 11096 end if; 11097 end; 11098 11099 elsif Present (Default_Expression (Formal)) then 11100 11101 -- Use default to construct declaration 11102 11103 if Present (Subt_Mark) then 11104 Def := New_Copy (Subt_Mark); 11105 else pragma Assert (Present (Acc_Def)); 11106 Def := Copy_Access_Def; 11107 end if; 11108 11109 Decl_Node := 11110 Make_Object_Declaration (Sloc (Formal), 11111 Defining_Identifier => New_Copy (Gen_Obj), 11112 Constant_Present => True, 11113 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11114 Object_Definition => Def, 11115 Expression => New_Copy_Tree 11116 (Default_Expression (Formal))); 11117 11118 Append (Decl_Node, List); 11119 Set_Analyzed (Expression (Decl_Node), False); 11120 11121 else 11122 Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj); 11123 Error_Msg_NE ("\in instantiation of & declared#", 11124 Instantiation_Node, Scope (A_Gen_Obj)); 11125 11126 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 11127 11128 -- Create dummy constant declaration so that instance can be 11129 -- analyzed, to minimize cascaded visibility errors. 11130 11131 if Present (Subt_Mark) then 11132 Def := Subt_Mark; 11133 else pragma Assert (Present (Acc_Def)); 11134 Def := Acc_Def; 11135 end if; 11136 11137 Decl_Node := 11138 Make_Object_Declaration (Loc, 11139 Defining_Identifier => New_Copy (Gen_Obj), 11140 Constant_Present => True, 11141 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11142 Object_Definition => New_Copy (Def), 11143 Expression => 11144 Make_Attribute_Reference (Sloc (Gen_Obj), 11145 Attribute_Name => Name_First, 11146 Prefix => New_Copy (Def))); 11147 11148 Append (Decl_Node, List); 11149 11150 else 11151 Abandon_Instantiation (Instantiation_Node); 11152 end if; 11153 end if; 11154 end if; 11155 11156 if Nkind (Actual) in N_Has_Entity then 11157 Actual_Decl := Parent (Entity (Actual)); 11158 end if; 11159 11160 -- Ada 2005 (AI-423): For a formal object declaration with a null 11161 -- exclusion or an access definition that has a null exclusion: If the 11162 -- actual matching the formal object declaration denotes a generic 11163 -- formal object of another generic unit G, and the instantiation 11164 -- containing the actual occurs within the body of G or within the body 11165 -- of a generic unit declared within the declarative region of G, then 11166 -- the declaration of the formal object of G must have a null exclusion. 11167 -- Otherwise, the subtype of the actual matching the formal object 11168 -- declaration shall exclude null. 11169 11170 if Ada_Version >= Ada_2005 11171 and then Present (Actual_Decl) 11172 and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 11173 N_Object_Declaration) 11174 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 11175 and then not Has_Null_Exclusion (Actual_Decl) 11176 and then Has_Null_Exclusion (Analyzed_Formal) 11177 then 11178 Error_Msg_Sloc := Sloc (Analyzed_Formal); 11179 Error_Msg_N 11180 ("actual must exclude null to match generic formal#", Actual); 11181 end if; 11182 11183 -- An effectively volatile object cannot be used as an actual in a 11184 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is 11185 -- relevant only when SPARK_Mode is on as it is not a standard Ada 11186 -- legality rule, and also verifies that the actual is an object. 11187 11188 if SPARK_Mode = On 11189 and then Present (Actual) 11190 and then Is_Object_Reference (Actual) 11191 and then Is_Effectively_Volatile_Object (Actual) 11192 then 11193 Error_Msg_N 11194 ("volatile object cannot act as actual in generic instantiation", 11195 Actual); 11196 end if; 11197 11198 return List; 11199 end Instantiate_Object; 11200 11201 ------------------------------ 11202 -- Instantiate_Package_Body -- 11203 ------------------------------ 11204 11205 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11206 -- must be replaced by gotos which jump to the end of the routine in order 11207 -- to restore the Ghost and SPARK modes. 11208 11209 procedure Instantiate_Package_Body 11210 (Body_Info : Pending_Body_Info; 11211 Inlined_Body : Boolean := False; 11212 Body_Optional : Boolean := False) 11213 is 11214 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11215 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11216 Act_Spec : constant Node_Id := Specification (Act_Decl); 11217 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11218 Gen_Id : constant Node_Id := Name (Inst_Node); 11219 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11220 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11221 Loc : constant Source_Ptr := Sloc (Inst_Node); 11222 11223 Saved_ISMP : constant Boolean := 11224 Ignore_SPARK_Mode_Pragmas_In_Instance; 11225 Saved_Style_Check : constant Boolean := Style_Check; 11226 11227 procedure Check_Initialized_Types; 11228 -- In a generic package body, an entity of a generic private type may 11229 -- appear uninitialized. This is suspicious, unless the actual is a 11230 -- fully initialized type. 11231 11232 ----------------------------- 11233 -- Check_Initialized_Types -- 11234 ----------------------------- 11235 11236 procedure Check_Initialized_Types is 11237 Decl : Node_Id; 11238 Formal : Entity_Id; 11239 Actual : Entity_Id; 11240 Uninit_Var : Entity_Id; 11241 11242 begin 11243 Decl := First (Generic_Formal_Declarations (Gen_Decl)); 11244 while Present (Decl) loop 11245 Uninit_Var := Empty; 11246 11247 if Nkind (Decl) = N_Private_Extension_Declaration then 11248 Uninit_Var := Uninitialized_Variable (Decl); 11249 11250 elsif Nkind (Decl) = N_Formal_Type_Declaration 11251 and then Nkind (Formal_Type_Definition (Decl)) = 11252 N_Formal_Private_Type_Definition 11253 then 11254 Uninit_Var := 11255 Uninitialized_Variable (Formal_Type_Definition (Decl)); 11256 end if; 11257 11258 if Present (Uninit_Var) then 11259 Formal := Defining_Identifier (Decl); 11260 Actual := First_Entity (Act_Decl_Id); 11261 11262 -- For each formal there is a subtype declaration that renames 11263 -- the actual and has the same name as the formal. Locate the 11264 -- formal for warning message about uninitialized variables 11265 -- in the generic, for which the actual type should be a fully 11266 -- initialized type. 11267 11268 while Present (Actual) loop 11269 exit when Ekind (Actual) = E_Package 11270 and then Present (Renamed_Object (Actual)); 11271 11272 if Chars (Actual) = Chars (Formal) 11273 and then not Is_Scalar_Type (Actual) 11274 and then not Is_Fully_Initialized_Type (Actual) 11275 and then Warn_On_No_Value_Assigned 11276 then 11277 Error_Msg_Node_2 := Formal; 11278 Error_Msg_NE 11279 ("generic unit has uninitialized variable& of " 11280 & "formal private type &?v?", Actual, Uninit_Var); 11281 Error_Msg_NE 11282 ("actual type for& should be fully initialized type?v?", 11283 Actual, Formal); 11284 exit; 11285 end if; 11286 11287 Next_Entity (Actual); 11288 end loop; 11289 end if; 11290 11291 Next (Decl); 11292 end loop; 11293 end Check_Initialized_Types; 11294 11295 -- Local variables 11296 11297 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11298 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11299 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11300 -- Save the Ghost and SPARK mode-related data to restore on exit 11301 11302 Act_Body : Node_Id; 11303 Act_Body_Id : Entity_Id; 11304 Act_Body_Name : Node_Id; 11305 Gen_Body : Node_Id; 11306 Gen_Body_Id : Node_Id; 11307 Par_Ent : Entity_Id := Empty; 11308 Par_Vis : Boolean := False; 11309 Parent_Installed : Boolean := False; 11310 11311 Vis_Prims_List : Elist_Id := No_Elist; 11312 -- List of primitives made temporarily visible in the instantiation 11313 -- to match the visibility of the formal type. 11314 11315 -- Start of processing for Instantiate_Package_Body 11316 11317 begin 11318 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11319 11320 -- The instance body may already have been processed, as the parent of 11321 -- another instance that is inlined (Load_Parent_Of_Generic). 11322 11323 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 11324 return; 11325 end if; 11326 11327 -- The package being instantiated may be subject to pragma Ghost. Set 11328 -- the mode now to ensure that any nodes generated during instantiation 11329 -- are properly marked as Ghost. 11330 11331 Set_Ghost_Mode (Act_Decl_Id); 11332 11333 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11334 11335 -- Re-establish the state of information on which checks are suppressed. 11336 -- This information was set in Body_Info at the point of instantiation, 11337 -- and now we restore it so that the instance is compiled using the 11338 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11339 11340 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11341 Scope_Suppress := Body_Info.Scope_Suppress; 11342 Opt.Ada_Version := Body_Info.Version; 11343 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 11344 Restore_Warnings (Body_Info.Warnings); 11345 11346 -- Install the SPARK mode which applies to the package body 11347 11348 Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma); 11349 11350 if No (Gen_Body_Id) then 11351 11352 -- Do not look for parent of generic body if none is required. 11353 -- This may happen when the routine is called as part of the 11354 -- Pending_Instantiations processing, when nested instances 11355 -- may precede the one generated from the main unit. 11356 11357 if not Unit_Requires_Body (Defining_Entity (Gen_Decl)) 11358 and then Body_Optional 11359 then 11360 goto Leave; 11361 else 11362 Load_Parent_Of_Generic 11363 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11364 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11365 end if; 11366 end if; 11367 11368 -- Establish global variable for sloc adjustment and for error recovery 11369 -- In the case of an instance body for an instantiation with actuals 11370 -- from a limited view, the instance body is placed at the beginning 11371 -- of the enclosing package body: use the body entity as the source 11372 -- location for nodes of the instance body. 11373 11374 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then 11375 declare 11376 Scop : constant Entity_Id := Scope (Act_Decl_Id); 11377 Body_Id : constant Node_Id := 11378 Corresponding_Body (Unit_Declaration_Node (Scop)); 11379 11380 begin 11381 Instantiation_Node := Body_Id; 11382 end; 11383 else 11384 Instantiation_Node := Inst_Node; 11385 end if; 11386 11387 if Present (Gen_Body_Id) then 11388 Save_Env (Gen_Unit, Act_Decl_Id); 11389 Style_Check := False; 11390 11391 -- If the context of the instance is subject to SPARK_Mode "off", the 11392 -- annotation is missing, or the body is instantiated at a later pass 11393 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11394 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11395 -- instance. 11396 11397 if SPARK_Mode /= On 11398 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11399 then 11400 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11401 end if; 11402 11403 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11404 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11405 11406 Create_Instantiation_Source 11407 (Inst_Node, Gen_Body_Id, S_Adjustment); 11408 11409 Act_Body := 11410 Copy_Generic_Node 11411 (Original_Node (Gen_Body), Empty, Instantiating => True); 11412 11413 -- Create proper (possibly qualified) defining name for the body, to 11414 -- correspond to the one in the spec. 11415 11416 Act_Body_Id := 11417 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11418 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11419 11420 -- Some attributes of spec entity are not inherited by body entity 11421 11422 Set_Handler_Records (Act_Body_Id, No_List); 11423 11424 if Nkind (Defining_Unit_Name (Act_Spec)) = 11425 N_Defining_Program_Unit_Name 11426 then 11427 Act_Body_Name := 11428 Make_Defining_Program_Unit_Name (Loc, 11429 Name => 11430 New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 11431 Defining_Identifier => Act_Body_Id); 11432 else 11433 Act_Body_Name := Act_Body_Id; 11434 end if; 11435 11436 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 11437 11438 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11439 Check_Generic_Actuals (Act_Decl_Id, False); 11440 Check_Initialized_Types; 11441 11442 -- Install primitives hidden at the point of the instantiation but 11443 -- visible when processing the generic formals 11444 11445 declare 11446 E : Entity_Id; 11447 11448 begin 11449 E := First_Entity (Act_Decl_Id); 11450 while Present (E) loop 11451 if Is_Type (E) 11452 and then not Is_Itype (E) 11453 and then Is_Generic_Actual_Type (E) 11454 and then Is_Tagged_Type (E) 11455 then 11456 Install_Hidden_Primitives 11457 (Prims_List => Vis_Prims_List, 11458 Gen_T => Generic_Parent_Type (Parent (E)), 11459 Act_T => E); 11460 end if; 11461 11462 Next_Entity (E); 11463 end loop; 11464 end; 11465 11466 -- If it is a child unit, make the parent instance (which is an 11467 -- instance of the parent of the generic) visible. The parent 11468 -- instance is the prefix of the name of the generic unit. 11469 11470 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11471 and then Nkind (Gen_Id) = N_Expanded_Name 11472 then 11473 Par_Ent := Entity (Prefix (Gen_Id)); 11474 Par_Vis := Is_Immediately_Visible (Par_Ent); 11475 Install_Parent (Par_Ent, In_Body => True); 11476 Parent_Installed := True; 11477 11478 elsif Is_Child_Unit (Gen_Unit) then 11479 Par_Ent := Scope (Gen_Unit); 11480 Par_Vis := Is_Immediately_Visible (Par_Ent); 11481 Install_Parent (Par_Ent, In_Body => True); 11482 Parent_Installed := True; 11483 end if; 11484 11485 -- If the instantiation is a library unit, and this is the main unit, 11486 -- then build the resulting compilation unit nodes for the instance. 11487 -- If this is a compilation unit but it is not the main unit, then it 11488 -- is the body of a unit in the context, that is being compiled 11489 -- because it is encloses some inlined unit or another generic unit 11490 -- being instantiated. In that case, this body is not part of the 11491 -- current compilation, and is not attached to the tree, but its 11492 -- parent must be set for analysis. 11493 11494 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11495 11496 -- Replace instance node with body of instance, and create new 11497 -- node for corresponding instance declaration. 11498 11499 Build_Instance_Compilation_Unit_Nodes 11500 (Inst_Node, Act_Body, Act_Decl); 11501 Analyze (Inst_Node); 11502 11503 if Parent (Inst_Node) = Cunit (Main_Unit) then 11504 11505 -- If the instance is a child unit itself, then set the scope 11506 -- of the expanded body to be the parent of the instantiation 11507 -- (ensuring that the fully qualified name will be generated 11508 -- for the elaboration subprogram). 11509 11510 if Nkind (Defining_Unit_Name (Act_Spec)) = 11511 N_Defining_Program_Unit_Name 11512 then 11513 Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 11514 end if; 11515 end if; 11516 11517 -- Case where instantiation is not a library unit 11518 11519 else 11520 -- If this is an early instantiation, i.e. appears textually 11521 -- before the corresponding body and must be elaborated first, 11522 -- indicate that the body instance is to be delayed. 11523 11524 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 11525 11526 -- Now analyze the body. We turn off all checks if this is an 11527 -- internal unit, since there is no reason to have checks on for 11528 -- any predefined run-time library code. All such code is designed 11529 -- to be compiled with checks off. 11530 11531 -- Note that we do NOT apply this criterion to children of GNAT 11532 -- The latter units must suppress checks explicitly if needed. 11533 11534 -- We also do not suppress checks in CodePeer mode where we are 11535 -- interested in finding possible runtime errors. 11536 11537 if not CodePeer_Mode 11538 and then In_Predefined_Unit (Gen_Decl) 11539 then 11540 Analyze (Act_Body, Suppress => All_Checks); 11541 else 11542 Analyze (Act_Body); 11543 end if; 11544 end if; 11545 11546 Inherit_Context (Gen_Body, Inst_Node); 11547 11548 -- Remove the parent instances if they have been placed on the scope 11549 -- stack to compile the body. 11550 11551 if Parent_Installed then 11552 Remove_Parent (In_Body => True); 11553 11554 -- Restore the previous visibility of the parent 11555 11556 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11557 end if; 11558 11559 Restore_Hidden_Primitives (Vis_Prims_List); 11560 Restore_Private_Views (Act_Decl_Id); 11561 11562 -- Remove the current unit from visibility if this is an instance 11563 -- that is not elaborated on the fly for inlining purposes. 11564 11565 if not Inlined_Body then 11566 Set_Is_Immediately_Visible (Act_Decl_Id, False); 11567 end if; 11568 11569 Restore_Env; 11570 11571 -- If we have no body, and the unit requires a body, then complain. This 11572 -- complaint is suppressed if we have detected other errors (since a 11573 -- common reason for missing the body is that it had errors). 11574 -- In CodePeer mode, a warning has been emitted already, no need for 11575 -- further messages. 11576 11577 elsif Unit_Requires_Body (Gen_Unit) 11578 and then not Body_Optional 11579 then 11580 if CodePeer_Mode then 11581 null; 11582 11583 elsif Serious_Errors_Detected = 0 then 11584 Error_Msg_NE 11585 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 11586 11587 -- Don't attempt to perform any cleanup actions if some other error 11588 -- was already detected, since this can cause blowups. 11589 11590 else 11591 goto Leave; 11592 end if; 11593 11594 -- Case of package that does not need a body 11595 11596 else 11597 -- If the instantiation of the declaration is a library unit, rewrite 11598 -- the original package instantiation as a package declaration in the 11599 -- compilation unit node. 11600 11601 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11602 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 11603 Rewrite (Inst_Node, Act_Decl); 11604 11605 -- Generate elaboration entity, in case spec has elaboration code. 11606 -- This cannot be done when the instance is analyzed, because it 11607 -- is not known yet whether the body exists. 11608 11609 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 11610 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 11611 11612 -- If the instantiation is not a library unit, then append the 11613 -- declaration to the list of implicitly generated entities, unless 11614 -- it is already a list member which means that it was already 11615 -- processed 11616 11617 elsif not Is_List_Member (Act_Decl) then 11618 Mark_Rewrite_Insertion (Act_Decl); 11619 Insert_Before (Inst_Node, Act_Decl); 11620 end if; 11621 end if; 11622 11623 Expander_Mode_Restore; 11624 11625 <<Leave>> 11626 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 11627 Restore_Ghost_Mode (Saved_GM); 11628 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 11629 Style_Check := Saved_Style_Check; 11630 end Instantiate_Package_Body; 11631 11632 --------------------------------- 11633 -- Instantiate_Subprogram_Body -- 11634 --------------------------------- 11635 11636 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11637 -- must be replaced by gotos which jump to the end of the routine in order 11638 -- to restore the Ghost and SPARK modes. 11639 11640 procedure Instantiate_Subprogram_Body 11641 (Body_Info : Pending_Body_Info; 11642 Body_Optional : Boolean := False) 11643 is 11644 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11645 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11646 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11647 Gen_Id : constant Node_Id := Name (Inst_Node); 11648 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11649 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11650 Loc : constant Source_Ptr := Sloc (Inst_Node); 11651 Pack_Id : constant Entity_Id := 11652 Defining_Unit_Name (Parent (Act_Decl)); 11653 11654 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11655 Saved_ISMP : constant Boolean := 11656 Ignore_SPARK_Mode_Pragmas_In_Instance; 11657 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11658 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11659 -- Save the Ghost and SPARK mode-related data to restore on exit 11660 11661 Saved_Style_Check : constant Boolean := Style_Check; 11662 Saved_Warnings : constant Warning_Record := Save_Warnings; 11663 11664 Act_Body : Node_Id; 11665 Act_Body_Id : Entity_Id; 11666 Gen_Body : Node_Id; 11667 Gen_Body_Id : Node_Id; 11668 Pack_Body : Node_Id; 11669 Par_Ent : Entity_Id := Empty; 11670 Par_Vis : Boolean := False; 11671 Ret_Expr : Node_Id; 11672 11673 Parent_Installed : Boolean := False; 11674 11675 begin 11676 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11677 11678 -- Subprogram body may have been created already because of an inline 11679 -- pragma, or because of multiple elaborations of the enclosing package 11680 -- when several instances of the subprogram appear in the main unit. 11681 11682 if Present (Corresponding_Body (Act_Decl)) then 11683 return; 11684 end if; 11685 11686 -- The subprogram being instantiated may be subject to pragma Ghost. Set 11687 -- the mode now to ensure that any nodes generated during instantiation 11688 -- are properly marked as Ghost. 11689 11690 Set_Ghost_Mode (Act_Decl_Id); 11691 11692 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11693 11694 -- Re-establish the state of information on which checks are suppressed. 11695 -- This information was set in Body_Info at the point of instantiation, 11696 -- and now we restore it so that the instance is compiled using the 11697 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11698 11699 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11700 Scope_Suppress := Body_Info.Scope_Suppress; 11701 Opt.Ada_Version := Body_Info.Version; 11702 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 11703 Restore_Warnings (Body_Info.Warnings); 11704 11705 -- Install the SPARK mode which applies to the subprogram body from the 11706 -- instantiation context. This may be refined further if an explicit 11707 -- SPARK_Mode pragma applies to the generic body. 11708 11709 Install_SPARK_Mode (Body_Info.SPARK_Mode, Body_Info.SPARK_Mode_Pragma); 11710 11711 if No (Gen_Body_Id) then 11712 11713 -- For imported generic subprogram, no body to compile, complete 11714 -- the spec entity appropriately. 11715 11716 if Is_Imported (Gen_Unit) then 11717 Set_Is_Imported (Act_Decl_Id); 11718 Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit)); 11719 Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); 11720 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 11721 Set_Has_Completion (Act_Decl_Id); 11722 goto Leave; 11723 11724 -- For other cases, compile the body 11725 11726 else 11727 Load_Parent_Of_Generic 11728 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11729 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11730 end if; 11731 end if; 11732 11733 Instantiation_Node := Inst_Node; 11734 11735 if Present (Gen_Body_Id) then 11736 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11737 11738 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 11739 11740 -- Either body is not present, or context is non-expanding, as 11741 -- when compiling a subunit. Mark the instance as completed, and 11742 -- diagnose a missing body when needed. 11743 11744 if Expander_Active 11745 and then Operating_Mode = Generate_Code 11746 then 11747 Error_Msg_N ("missing proper body for instantiation", Gen_Body); 11748 end if; 11749 11750 Set_Has_Completion (Act_Decl_Id); 11751 goto Leave; 11752 end if; 11753 11754 Save_Env (Gen_Unit, Act_Decl_Id); 11755 Style_Check := False; 11756 11757 -- If the context of the instance is subject to SPARK_Mode "off", the 11758 -- annotation is missing, or the body is instantiated at a later pass 11759 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11760 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11761 -- instance. 11762 11763 if SPARK_Mode /= On 11764 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11765 then 11766 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11767 end if; 11768 11769 -- If the context of an instance is not subject to SPARK_Mode "off", 11770 -- and the generic body is subject to an explicit SPARK_Mode pragma, 11771 -- the latter should be the one applicable to the instance. 11772 11773 if not Ignore_SPARK_Mode_Pragmas_In_Instance 11774 and then SPARK_Mode /= Off 11775 and then Present (SPARK_Pragma (Gen_Body_Id)) 11776 then 11777 Set_SPARK_Mode (Gen_Body_Id); 11778 end if; 11779 11780 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11781 Create_Instantiation_Source 11782 (Inst_Node, 11783 Gen_Body_Id, 11784 S_Adjustment); 11785 11786 Act_Body := 11787 Copy_Generic_Node 11788 (Original_Node (Gen_Body), Empty, Instantiating => True); 11789 11790 -- Create proper defining name for the body, to correspond to the one 11791 -- in the spec. 11792 11793 Act_Body_Id := 11794 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11795 11796 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11797 Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); 11798 11799 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11800 Set_Has_Completion (Act_Decl_Id); 11801 Check_Generic_Actuals (Pack_Id, False); 11802 11803 -- Generate a reference to link the visible subprogram instance to 11804 -- the generic body, which for navigation purposes is the only 11805 -- available source for the instance. 11806 11807 Generate_Reference 11808 (Related_Instance (Pack_Id), 11809 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 11810 11811 -- If it is a child unit, make the parent instance (which is an 11812 -- instance of the parent of the generic) visible. The parent 11813 -- instance is the prefix of the name of the generic unit. 11814 11815 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11816 and then Nkind (Gen_Id) = N_Expanded_Name 11817 then 11818 Par_Ent := Entity (Prefix (Gen_Id)); 11819 Par_Vis := Is_Immediately_Visible (Par_Ent); 11820 Install_Parent (Par_Ent, In_Body => True); 11821 Parent_Installed := True; 11822 11823 elsif Is_Child_Unit (Gen_Unit) then 11824 Par_Ent := Scope (Gen_Unit); 11825 Par_Vis := Is_Immediately_Visible (Par_Ent); 11826 Install_Parent (Par_Ent, In_Body => True); 11827 Parent_Installed := True; 11828 end if; 11829 11830 -- Subprogram body is placed in the body of wrapper package, 11831 -- whose spec contains the subprogram declaration as well as 11832 -- the renaming declarations for the generic parameters. 11833 11834 Pack_Body := 11835 Make_Package_Body (Loc, 11836 Defining_Unit_Name => New_Copy (Pack_Id), 11837 Declarations => New_List (Act_Body)); 11838 11839 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11840 11841 -- If the instantiation is a library unit, then build resulting 11842 -- compilation unit nodes for the instance. The declaration of 11843 -- the enclosing package is the grandparent of the subprogram 11844 -- declaration. First replace the instantiation node as the unit 11845 -- of the corresponding compilation. 11846 11847 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11848 if Parent (Inst_Node) = Cunit (Main_Unit) then 11849 Set_Unit (Parent (Inst_Node), Inst_Node); 11850 Build_Instance_Compilation_Unit_Nodes 11851 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 11852 Analyze (Inst_Node); 11853 else 11854 Set_Parent (Pack_Body, Parent (Inst_Node)); 11855 Analyze (Pack_Body); 11856 end if; 11857 11858 else 11859 Insert_Before (Inst_Node, Pack_Body); 11860 Mark_Rewrite_Insertion (Pack_Body); 11861 Analyze (Pack_Body); 11862 11863 if Expander_Active then 11864 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 11865 end if; 11866 end if; 11867 11868 Inherit_Context (Gen_Body, Inst_Node); 11869 11870 Restore_Private_Views (Pack_Id, False); 11871 11872 if Parent_Installed then 11873 Remove_Parent (In_Body => True); 11874 11875 -- Restore the previous visibility of the parent 11876 11877 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11878 end if; 11879 11880 Restore_Env; 11881 Restore_Warnings (Saved_Warnings); 11882 11883 -- Body not found. Error was emitted already. If there were no previous 11884 -- errors, this may be an instance whose scope is a premature instance. 11885 -- In that case we must insure that the (legal) program does raise 11886 -- program error if executed. We generate a subprogram body for this 11887 -- purpose. See DEC ac30vso. 11888 11889 -- Should not reference proprietary DEC tests in comments ??? 11890 11891 elsif Serious_Errors_Detected = 0 11892 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 11893 then 11894 if Body_Optional then 11895 goto Leave; 11896 11897 elsif Ekind (Act_Decl_Id) = E_Procedure then 11898 Act_Body := 11899 Make_Subprogram_Body (Loc, 11900 Specification => 11901 Make_Procedure_Specification (Loc, 11902 Defining_Unit_Name => 11903 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11904 Parameter_Specifications => 11905 New_Copy_List 11906 (Parameter_Specifications (Parent (Act_Decl_Id)))), 11907 11908 Declarations => Empty_List, 11909 Handled_Statement_Sequence => 11910 Make_Handled_Sequence_Of_Statements (Loc, 11911 Statements => New_List ( 11912 Make_Raise_Program_Error (Loc, 11913 Reason => PE_Access_Before_Elaboration)))); 11914 11915 else 11916 Ret_Expr := 11917 Make_Raise_Program_Error (Loc, 11918 Reason => PE_Access_Before_Elaboration); 11919 11920 Set_Etype (Ret_Expr, (Etype (Act_Decl_Id))); 11921 Set_Analyzed (Ret_Expr); 11922 11923 Act_Body := 11924 Make_Subprogram_Body (Loc, 11925 Specification => 11926 Make_Function_Specification (Loc, 11927 Defining_Unit_Name => 11928 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 11929 Parameter_Specifications => 11930 New_Copy_List 11931 (Parameter_Specifications (Parent (Act_Decl_Id))), 11932 Result_Definition => 11933 New_Occurrence_Of (Etype (Act_Decl_Id), Loc)), 11934 11935 Declarations => Empty_List, 11936 Handled_Statement_Sequence => 11937 Make_Handled_Sequence_Of_Statements (Loc, 11938 Statements => New_List ( 11939 Make_Simple_Return_Statement (Loc, Ret_Expr)))); 11940 end if; 11941 11942 Pack_Body := 11943 Make_Package_Body (Loc, 11944 Defining_Unit_Name => New_Copy (Pack_Id), 11945 Declarations => New_List (Act_Body)); 11946 11947 Insert_After (Inst_Node, Pack_Body); 11948 Set_Corresponding_Spec (Pack_Body, Pack_Id); 11949 Analyze (Pack_Body); 11950 end if; 11951 11952 Expander_Mode_Restore; 11953 11954 <<Leave>> 11955 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 11956 Restore_Ghost_Mode (Saved_GM); 11957 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 11958 Style_Check := Saved_Style_Check; 11959 end Instantiate_Subprogram_Body; 11960 11961 ---------------------- 11962 -- Instantiate_Type -- 11963 ---------------------- 11964 11965 function Instantiate_Type 11966 (Formal : Node_Id; 11967 Actual : Node_Id; 11968 Analyzed_Formal : Node_Id; 11969 Actual_Decls : List_Id) return List_Id 11970 is 11971 A_Gen_T : constant Entity_Id := 11972 Defining_Identifier (Analyzed_Formal); 11973 Def : constant Node_Id := Formal_Type_Definition (Formal); 11974 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 11975 Act_T : Entity_Id; 11976 Ancestor : Entity_Id := Empty; 11977 Decl_Node : Node_Id; 11978 Decl_Nodes : List_Id; 11979 Loc : Source_Ptr; 11980 Subt : Entity_Id; 11981 11982 procedure Diagnose_Predicated_Actual; 11983 -- There are a number of constructs in which a discrete type with 11984 -- predicates is illegal, e.g. as an index in an array type declaration. 11985 -- If a generic type is used is such a construct in a generic package 11986 -- declaration, it carries the flag No_Predicate_On_Actual. it is part 11987 -- of the generic contract that the actual cannot have predicates. 11988 11989 procedure Validate_Array_Type_Instance; 11990 procedure Validate_Access_Subprogram_Instance; 11991 procedure Validate_Access_Type_Instance; 11992 procedure Validate_Derived_Type_Instance; 11993 procedure Validate_Derived_Interface_Type_Instance; 11994 procedure Validate_Discriminated_Formal_Type; 11995 procedure Validate_Interface_Type_Instance; 11996 procedure Validate_Private_Type_Instance; 11997 procedure Validate_Incomplete_Type_Instance; 11998 -- These procedures perform validation tests for the named case. 11999 -- Validate_Discriminated_Formal_Type is shared by formal private 12000 -- types and Ada 2012 formal incomplete types. 12001 12002 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 12003 -- Check that base types are the same and that the subtypes match 12004 -- statically. Used in several of the above. 12005 12006 --------------------------------- 12007 -- Diagnose_Predicated_Actual -- 12008 --------------------------------- 12009 12010 procedure Diagnose_Predicated_Actual is 12011 begin 12012 if No_Predicate_On_Actual (A_Gen_T) 12013 and then Has_Predicates (Act_T) 12014 then 12015 Error_Msg_NE 12016 ("actual for& cannot be a type with predicate", 12017 Instantiation_Node, A_Gen_T); 12018 12019 elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) 12020 and then Has_Predicates (Act_T) 12021 and then not Has_Static_Predicate_Aspect (Act_T) 12022 then 12023 Error_Msg_NE 12024 ("actual for& cannot be a type with a dynamic predicate", 12025 Instantiation_Node, A_Gen_T); 12026 end if; 12027 end Diagnose_Predicated_Actual; 12028 12029 -------------------- 12030 -- Subtypes_Match -- 12031 -------------------- 12032 12033 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 12034 T : constant Entity_Id := Get_Instance_Of (Gen_T); 12035 12036 begin 12037 -- Some detailed comments would be useful here ??? 12038 12039 return ((Base_Type (T) = Act_T 12040 or else Base_Type (T) = Base_Type (Act_T)) 12041 and then Subtypes_Statically_Match (T, Act_T)) 12042 12043 or else (Is_Class_Wide_Type (Gen_T) 12044 and then Is_Class_Wide_Type (Act_T) 12045 and then Subtypes_Match 12046 (Get_Instance_Of (Root_Type (Gen_T)), 12047 Root_Type (Act_T))) 12048 12049 or else 12050 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 12051 E_Anonymous_Access_Type) 12052 and then Ekind (Act_T) = Ekind (Gen_T) 12053 and then Subtypes_Statically_Match 12054 (Designated_Type (Gen_T), Designated_Type (Act_T))); 12055 end Subtypes_Match; 12056 12057 ----------------------------------------- 12058 -- Validate_Access_Subprogram_Instance -- 12059 ----------------------------------------- 12060 12061 procedure Validate_Access_Subprogram_Instance is 12062 begin 12063 if not Is_Access_Type (Act_T) 12064 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 12065 then 12066 Error_Msg_NE 12067 ("expect access type in instantiation of &", Actual, Gen_T); 12068 Abandon_Instantiation (Actual); 12069 end if; 12070 12071 -- According to AI05-288, actuals for access_to_subprograms must be 12072 -- subtype conformant with the generic formal. Previous to AI05-288 12073 -- only mode conformance was required. 12074 12075 -- This is a binding interpretation that applies to previous versions 12076 -- of the language, no need to maintain previous weaker checks. 12077 12078 Check_Subtype_Conformant 12079 (Designated_Type (Act_T), 12080 Designated_Type (A_Gen_T), 12081 Actual, 12082 Get_Inst => True); 12083 12084 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 12085 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 12086 Error_Msg_NE 12087 ("protected access type not allowed for formal &", 12088 Actual, Gen_T); 12089 end if; 12090 12091 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 12092 Error_Msg_NE 12093 ("expect protected access type for formal &", 12094 Actual, Gen_T); 12095 end if; 12096 12097 -- If the formal has a specified convention (which in most cases 12098 -- will be StdCall) verify that the actual has the same convention. 12099 12100 if Has_Convention_Pragma (A_Gen_T) 12101 and then Convention (A_Gen_T) /= Convention (Act_T) 12102 then 12103 Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T)); 12104 Error_Msg_NE 12105 ("actual for formal & must have convention %", Actual, Gen_T); 12106 end if; 12107 end Validate_Access_Subprogram_Instance; 12108 12109 ----------------------------------- 12110 -- Validate_Access_Type_Instance -- 12111 ----------------------------------- 12112 12113 procedure Validate_Access_Type_Instance is 12114 Desig_Type : constant Entity_Id := 12115 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 12116 Desig_Act : Entity_Id; 12117 12118 begin 12119 if not Is_Access_Type (Act_T) then 12120 Error_Msg_NE 12121 ("expect access type in instantiation of &", Actual, Gen_T); 12122 Abandon_Instantiation (Actual); 12123 end if; 12124 12125 if Is_Access_Constant (A_Gen_T) then 12126 if not Is_Access_Constant (Act_T) then 12127 Error_Msg_N 12128 ("actual type must be access-to-constant type", Actual); 12129 Abandon_Instantiation (Actual); 12130 end if; 12131 else 12132 if Is_Access_Constant (Act_T) then 12133 Error_Msg_N 12134 ("actual type must be access-to-variable type", Actual); 12135 Abandon_Instantiation (Actual); 12136 12137 elsif Ekind (A_Gen_T) = E_General_Access_Type 12138 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 12139 then 12140 Error_Msg_N -- CODEFIX 12141 ("actual must be general access type!", Actual); 12142 Error_Msg_NE -- CODEFIX 12143 ("add ALL to }!", Actual, Act_T); 12144 Abandon_Instantiation (Actual); 12145 end if; 12146 end if; 12147 12148 -- The designated subtypes, that is to say the subtypes introduced 12149 -- by an access type declaration (and not by a subtype declaration) 12150 -- must match. 12151 12152 Desig_Act := Designated_Type (Base_Type (Act_T)); 12153 12154 -- The designated type may have been introduced through a limited_ 12155 -- with clause, in which case retrieve the non-limited view. This 12156 -- applies to incomplete types as well as to class-wide types. 12157 12158 if From_Limited_With (Desig_Act) then 12159 Desig_Act := Available_View (Desig_Act); 12160 end if; 12161 12162 if not Subtypes_Match (Desig_Type, Desig_Act) then 12163 Error_Msg_NE 12164 ("designated type of actual does not match that of formal &", 12165 Actual, Gen_T); 12166 12167 if not Predicates_Match (Desig_Type, Desig_Act) then 12168 Error_Msg_N ("\predicates do not match", Actual); 12169 end if; 12170 12171 Abandon_Instantiation (Actual); 12172 12173 elsif Is_Access_Type (Designated_Type (Act_T)) 12174 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 12175 /= 12176 Is_Constrained (Designated_Type (Desig_Type)) 12177 then 12178 Error_Msg_NE 12179 ("designated type of actual does not match that of formal &", 12180 Actual, Gen_T); 12181 12182 if not Predicates_Match (Desig_Type, Desig_Act) then 12183 Error_Msg_N ("\predicates do not match", Actual); 12184 end if; 12185 12186 Abandon_Instantiation (Actual); 12187 end if; 12188 12189 -- Ada 2005: null-exclusion indicators of the two types must agree 12190 12191 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 12192 Error_Msg_NE 12193 ("non null exclusion of actual and formal & do not match", 12194 Actual, Gen_T); 12195 end if; 12196 end Validate_Access_Type_Instance; 12197 12198 ---------------------------------- 12199 -- Validate_Array_Type_Instance -- 12200 ---------------------------------- 12201 12202 procedure Validate_Array_Type_Instance is 12203 I1 : Node_Id; 12204 I2 : Node_Id; 12205 T2 : Entity_Id; 12206 12207 function Formal_Dimensions return Nat; 12208 -- Count number of dimensions in array type formal 12209 12210 ----------------------- 12211 -- Formal_Dimensions -- 12212 ----------------------- 12213 12214 function Formal_Dimensions return Nat is 12215 Num : Nat := 0; 12216 Index : Node_Id; 12217 12218 begin 12219 if Nkind (Def) = N_Constrained_Array_Definition then 12220 Index := First (Discrete_Subtype_Definitions (Def)); 12221 else 12222 Index := First (Subtype_Marks (Def)); 12223 end if; 12224 12225 while Present (Index) loop 12226 Num := Num + 1; 12227 Next_Index (Index); 12228 end loop; 12229 12230 return Num; 12231 end Formal_Dimensions; 12232 12233 -- Start of processing for Validate_Array_Type_Instance 12234 12235 begin 12236 if not Is_Array_Type (Act_T) then 12237 Error_Msg_NE 12238 ("expect array type in instantiation of &", Actual, Gen_T); 12239 Abandon_Instantiation (Actual); 12240 12241 elsif Nkind (Def) = N_Constrained_Array_Definition then 12242 if not (Is_Constrained (Act_T)) then 12243 Error_Msg_NE 12244 ("expect constrained array in instantiation of &", 12245 Actual, Gen_T); 12246 Abandon_Instantiation (Actual); 12247 end if; 12248 12249 else 12250 if Is_Constrained (Act_T) then 12251 Error_Msg_NE 12252 ("expect unconstrained array in instantiation of &", 12253 Actual, Gen_T); 12254 Abandon_Instantiation (Actual); 12255 end if; 12256 end if; 12257 12258 if Formal_Dimensions /= Number_Dimensions (Act_T) then 12259 Error_Msg_NE 12260 ("dimensions of actual do not match formal &", Actual, Gen_T); 12261 Abandon_Instantiation (Actual); 12262 end if; 12263 12264 I1 := First_Index (A_Gen_T); 12265 I2 := First_Index (Act_T); 12266 for J in 1 .. Formal_Dimensions loop 12267 12268 -- If the indexes of the actual were given by a subtype_mark, 12269 -- the index was transformed into a range attribute. Retrieve 12270 -- the original type mark for checking. 12271 12272 if Is_Entity_Name (Original_Node (I2)) then 12273 T2 := Entity (Original_Node (I2)); 12274 else 12275 T2 := Etype (I2); 12276 end if; 12277 12278 if not Subtypes_Match 12279 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 12280 then 12281 Error_Msg_NE 12282 ("index types of actual do not match those of formal &", 12283 Actual, Gen_T); 12284 Abandon_Instantiation (Actual); 12285 end if; 12286 12287 Next_Index (I1); 12288 Next_Index (I2); 12289 end loop; 12290 12291 -- Check matching subtypes. Note that there are complex visibility 12292 -- issues when the generic is a child unit and some aspect of the 12293 -- generic type is declared in a parent unit of the generic. We do 12294 -- the test to handle this special case only after a direct check 12295 -- for static matching has failed. The case where both the component 12296 -- type and the array type are separate formals, and the component 12297 -- type is a private view may also require special checking in 12298 -- Subtypes_Match. Finally, we assume that a child instance where 12299 -- the component type comes from a formal of a parent instance is 12300 -- correct because the generic was correct. A more precise check 12301 -- seems too complex to install??? 12302 12303 if Subtypes_Match 12304 (Component_Type (A_Gen_T), Component_Type (Act_T)) 12305 or else 12306 Subtypes_Match 12307 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 12308 Component_Type (Act_T)) 12309 or else 12310 (not Inside_A_Generic 12311 and then Is_Child_Unit (Scope (Component_Type (A_Gen_T)))) 12312 then 12313 null; 12314 else 12315 Error_Msg_NE 12316 ("component subtype of actual does not match that of formal &", 12317 Actual, Gen_T); 12318 Abandon_Instantiation (Actual); 12319 end if; 12320 12321 if Has_Aliased_Components (A_Gen_T) 12322 and then not Has_Aliased_Components (Act_T) 12323 then 12324 Error_Msg_NE 12325 ("actual must have aliased components to match formal type &", 12326 Actual, Gen_T); 12327 end if; 12328 end Validate_Array_Type_Instance; 12329 12330 ----------------------------------------------- 12331 -- Validate_Derived_Interface_Type_Instance -- 12332 ----------------------------------------------- 12333 12334 procedure Validate_Derived_Interface_Type_Instance is 12335 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 12336 Elmt : Elmt_Id; 12337 12338 begin 12339 -- First apply interface instance checks 12340 12341 Validate_Interface_Type_Instance; 12342 12343 -- Verify that immediate parent interface is an ancestor of 12344 -- the actual. 12345 12346 if Present (Par) 12347 and then not Interface_Present_In_Ancestor (Act_T, Par) 12348 then 12349 Error_Msg_NE 12350 ("interface actual must include progenitor&", Actual, Par); 12351 end if; 12352 12353 -- Now verify that the actual includes all other ancestors of 12354 -- the formal. 12355 12356 Elmt := First_Elmt (Interfaces (A_Gen_T)); 12357 while Present (Elmt) loop 12358 if not Interface_Present_In_Ancestor 12359 (Act_T, Get_Instance_Of (Node (Elmt))) 12360 then 12361 Error_Msg_NE 12362 ("interface actual must include progenitor&", 12363 Actual, Node (Elmt)); 12364 end if; 12365 12366 Next_Elmt (Elmt); 12367 end loop; 12368 end Validate_Derived_Interface_Type_Instance; 12369 12370 ------------------------------------ 12371 -- Validate_Derived_Type_Instance -- 12372 ------------------------------------ 12373 12374 procedure Validate_Derived_Type_Instance is 12375 Actual_Discr : Entity_Id; 12376 Ancestor_Discr : Entity_Id; 12377 12378 begin 12379 -- If the parent type in the generic declaration is itself a previous 12380 -- formal type, then it is local to the generic and absent from the 12381 -- analyzed generic definition. In that case the ancestor is the 12382 -- instance of the formal (which must have been instantiated 12383 -- previously), unless the ancestor is itself a formal derived type. 12384 -- In this latter case (which is the subject of Corrigendum 8652/0038 12385 -- (AI-202) the ancestor of the formals is the ancestor of its 12386 -- parent. Otherwise, the analyzed generic carries the parent type. 12387 -- If the parent type is defined in a previous formal package, then 12388 -- the scope of that formal package is that of the generic type 12389 -- itself, and it has already been mapped into the corresponding type 12390 -- in the actual package. 12391 12392 -- Common case: parent type defined outside of the generic 12393 12394 if Is_Entity_Name (Subtype_Mark (Def)) 12395 and then Present (Entity (Subtype_Mark (Def))) 12396 then 12397 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 12398 12399 -- Check whether parent is defined in a previous formal package 12400 12401 elsif 12402 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 12403 then 12404 Ancestor := 12405 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 12406 12407 -- The type may be a local derivation, or a type extension of a 12408 -- previous formal, or of a formal of a parent package. 12409 12410 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 12411 or else 12412 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 12413 then 12414 -- Check whether the parent is another derived formal type in the 12415 -- same generic unit. 12416 12417 if Etype (A_Gen_T) /= A_Gen_T 12418 and then Is_Generic_Type (Etype (A_Gen_T)) 12419 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 12420 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 12421 then 12422 -- Locate ancestor of parent from the subtype declaration 12423 -- created for the actual. 12424 12425 declare 12426 Decl : Node_Id; 12427 12428 begin 12429 Decl := First (Actual_Decls); 12430 while Present (Decl) loop 12431 if Nkind (Decl) = N_Subtype_Declaration 12432 and then Chars (Defining_Identifier (Decl)) = 12433 Chars (Etype (A_Gen_T)) 12434 then 12435 Ancestor := Generic_Parent_Type (Decl); 12436 exit; 12437 else 12438 Next (Decl); 12439 end if; 12440 end loop; 12441 end; 12442 12443 pragma Assert (Present (Ancestor)); 12444 12445 -- The ancestor itself may be a previous formal that has been 12446 -- instantiated. 12447 12448 Ancestor := Get_Instance_Of (Ancestor); 12449 12450 else 12451 Ancestor := 12452 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 12453 end if; 12454 12455 -- Check whether parent is a previous formal of the current generic 12456 12457 elsif Is_Derived_Type (A_Gen_T) 12458 and then Is_Generic_Type (Etype (A_Gen_T)) 12459 and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T)) 12460 then 12461 Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T))); 12462 12463 -- An unusual case: the actual is a type declared in a parent unit, 12464 -- but is not a formal type so there is no instance_of for it. 12465 -- Retrieve it by analyzing the record extension. 12466 12467 elsif Is_Child_Unit (Scope (A_Gen_T)) 12468 and then In_Open_Scopes (Scope (Act_T)) 12469 and then Is_Generic_Instance (Scope (Act_T)) 12470 then 12471 Analyze (Subtype_Mark (Def)); 12472 Ancestor := Entity (Subtype_Mark (Def)); 12473 12474 else 12475 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 12476 end if; 12477 12478 -- If the formal derived type has pragma Preelaborable_Initialization 12479 -- then the actual type must have preelaborable initialization. 12480 12481 if Known_To_Have_Preelab_Init (A_Gen_T) 12482 and then not Has_Preelaborable_Initialization (Act_T) 12483 then 12484 Error_Msg_NE 12485 ("actual for & must have preelaborable initialization", 12486 Actual, Gen_T); 12487 end if; 12488 12489 -- Ada 2005 (AI-251) 12490 12491 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then 12492 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 12493 Error_Msg_NE 12494 ("(Ada 2005) expected type implementing & in instantiation", 12495 Actual, Ancestor); 12496 end if; 12497 12498 -- Finally verify that the (instance of) the ancestor is an ancestor 12499 -- of the actual. 12500 12501 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 12502 Error_Msg_NE 12503 ("expect type derived from & in instantiation", 12504 Actual, First_Subtype (Ancestor)); 12505 Abandon_Instantiation (Actual); 12506 end if; 12507 12508 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 12509 -- that the formal type declaration has been rewritten as a private 12510 -- extension. 12511 12512 if Ada_Version >= Ada_2005 12513 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 12514 and then Synchronized_Present (Parent (A_Gen_T)) 12515 then 12516 -- The actual must be a synchronized tagged type 12517 12518 if not Is_Tagged_Type (Act_T) then 12519 Error_Msg_N 12520 ("actual of synchronized type must be tagged", Actual); 12521 Abandon_Instantiation (Actual); 12522 12523 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 12524 and then Nkind (Type_Definition (Parent (Act_T))) = 12525 N_Derived_Type_Definition 12526 and then not Synchronized_Present 12527 (Type_Definition (Parent (Act_T))) 12528 then 12529 Error_Msg_N 12530 ("actual of synchronized type must be synchronized", Actual); 12531 Abandon_Instantiation (Actual); 12532 end if; 12533 end if; 12534 12535 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 12536 -- removes the second instance of the phrase "or allow pass by copy". 12537 12538 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then 12539 Error_Msg_N 12540 ("cannot have atomic actual type for non-atomic formal type", 12541 Actual); 12542 12543 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then 12544 Error_Msg_N 12545 ("cannot have volatile actual type for non-volatile formal type", 12546 Actual); 12547 end if; 12548 12549 -- It should not be necessary to check for unknown discriminants on 12550 -- Formal, but for some reason Has_Unknown_Discriminants is false for 12551 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This 12552 -- needs fixing. ??? 12553 12554 if Is_Definite_Subtype (A_Gen_T) 12555 and then not Unknown_Discriminants_Present (Formal) 12556 and then not Is_Definite_Subtype (Act_T) 12557 then 12558 Error_Msg_N ("actual subtype must be constrained", Actual); 12559 Abandon_Instantiation (Actual); 12560 end if; 12561 12562 if not Unknown_Discriminants_Present (Formal) then 12563 if Is_Constrained (Ancestor) then 12564 if not Is_Constrained (Act_T) then 12565 Error_Msg_N ("actual subtype must be constrained", Actual); 12566 Abandon_Instantiation (Actual); 12567 end if; 12568 12569 -- Ancestor is unconstrained, Check if generic formal and actual 12570 -- agree on constrainedness. The check only applies to array types 12571 -- and discriminated types. 12572 12573 elsif Is_Constrained (Act_T) then 12574 if Ekind (Ancestor) = E_Access_Type 12575 or else (not Is_Constrained (A_Gen_T) 12576 and then Is_Composite_Type (A_Gen_T)) 12577 then 12578 Error_Msg_N ("actual subtype must be unconstrained", Actual); 12579 Abandon_Instantiation (Actual); 12580 end if; 12581 12582 -- A class-wide type is only allowed if the formal has unknown 12583 -- discriminants. 12584 12585 elsif Is_Class_Wide_Type (Act_T) 12586 and then not Has_Unknown_Discriminants (Ancestor) 12587 then 12588 Error_Msg_NE 12589 ("actual for & cannot be a class-wide type", Actual, Gen_T); 12590 Abandon_Instantiation (Actual); 12591 12592 -- Otherwise, the formal and actual must have the same number 12593 -- of discriminants and each discriminant of the actual must 12594 -- correspond to a discriminant of the formal. 12595 12596 elsif Has_Discriminants (Act_T) 12597 and then not Has_Unknown_Discriminants (Act_T) 12598 and then Has_Discriminants (Ancestor) 12599 then 12600 Actual_Discr := First_Discriminant (Act_T); 12601 Ancestor_Discr := First_Discriminant (Ancestor); 12602 while Present (Actual_Discr) 12603 and then Present (Ancestor_Discr) 12604 loop 12605 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 12606 No (Corresponding_Discriminant (Actual_Discr)) 12607 then 12608 Error_Msg_NE 12609 ("discriminant & does not correspond " 12610 & "to ancestor discriminant", Actual, Actual_Discr); 12611 Abandon_Instantiation (Actual); 12612 end if; 12613 12614 Next_Discriminant (Actual_Discr); 12615 Next_Discriminant (Ancestor_Discr); 12616 end loop; 12617 12618 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 12619 Error_Msg_NE 12620 ("actual for & must have same number of discriminants", 12621 Actual, Gen_T); 12622 Abandon_Instantiation (Actual); 12623 end if; 12624 12625 -- This case should be caught by the earlier check for 12626 -- constrainedness, but the check here is added for completeness. 12627 12628 elsif Has_Discriminants (Act_T) 12629 and then not Has_Unknown_Discriminants (Act_T) 12630 then 12631 Error_Msg_NE 12632 ("actual for & must not have discriminants", Actual, Gen_T); 12633 Abandon_Instantiation (Actual); 12634 12635 elsif Has_Discriminants (Ancestor) then 12636 Error_Msg_NE 12637 ("actual for & must have known discriminants", Actual, Gen_T); 12638 Abandon_Instantiation (Actual); 12639 end if; 12640 12641 if not Subtypes_Statically_Compatible 12642 (Act_T, Ancestor, Formal_Derived_Matching => True) 12643 then 12644 Error_Msg_N 12645 ("constraint on actual is incompatible with formal", Actual); 12646 Abandon_Instantiation (Actual); 12647 end if; 12648 end if; 12649 12650 -- If the formal and actual types are abstract, check that there 12651 -- are no abstract primitives of the actual type that correspond to 12652 -- nonabstract primitives of the formal type (second sentence of 12653 -- RM95 3.9.3(9)). 12654 12655 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 12656 Check_Abstract_Primitives : declare 12657 Gen_Prims : constant Elist_Id := 12658 Primitive_Operations (A_Gen_T); 12659 Gen_Elmt : Elmt_Id; 12660 Gen_Subp : Entity_Id; 12661 Anc_Subp : Entity_Id; 12662 Anc_Formal : Entity_Id; 12663 Anc_F_Type : Entity_Id; 12664 12665 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 12666 Act_Elmt : Elmt_Id; 12667 Act_Subp : Entity_Id; 12668 Act_Formal : Entity_Id; 12669 Act_F_Type : Entity_Id; 12670 12671 Subprograms_Correspond : Boolean; 12672 12673 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 12674 -- Returns true if T2 is derived directly or indirectly from 12675 -- T1, including derivations from interfaces. T1 and T2 are 12676 -- required to be specific tagged base types. 12677 12678 ------------------------ 12679 -- Is_Tagged_Ancestor -- 12680 ------------------------ 12681 12682 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 12683 is 12684 Intfc_Elmt : Elmt_Id; 12685 12686 begin 12687 -- The predicate is satisfied if the types are the same 12688 12689 if T1 = T2 then 12690 return True; 12691 12692 -- If we've reached the top of the derivation chain then 12693 -- we know that T1 is not an ancestor of T2. 12694 12695 elsif Etype (T2) = T2 then 12696 return False; 12697 12698 -- Proceed to check T2's immediate parent 12699 12700 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 12701 return True; 12702 12703 -- Finally, check to see if T1 is an ancestor of any of T2's 12704 -- progenitors. 12705 12706 else 12707 Intfc_Elmt := First_Elmt (Interfaces (T2)); 12708 while Present (Intfc_Elmt) loop 12709 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 12710 return True; 12711 end if; 12712 12713 Next_Elmt (Intfc_Elmt); 12714 end loop; 12715 end if; 12716 12717 return False; 12718 end Is_Tagged_Ancestor; 12719 12720 -- Start of processing for Check_Abstract_Primitives 12721 12722 begin 12723 -- Loop over all of the formal derived type's primitives 12724 12725 Gen_Elmt := First_Elmt (Gen_Prims); 12726 while Present (Gen_Elmt) loop 12727 Gen_Subp := Node (Gen_Elmt); 12728 12729 -- If the primitive of the formal is not abstract, then 12730 -- determine whether there is a corresponding primitive of 12731 -- the actual type that's abstract. 12732 12733 if not Is_Abstract_Subprogram (Gen_Subp) then 12734 Act_Elmt := First_Elmt (Act_Prims); 12735 while Present (Act_Elmt) loop 12736 Act_Subp := Node (Act_Elmt); 12737 12738 -- If we find an abstract primitive of the actual, 12739 -- then we need to test whether it corresponds to the 12740 -- subprogram from which the generic formal primitive 12741 -- is inherited. 12742 12743 if Is_Abstract_Subprogram (Act_Subp) then 12744 Anc_Subp := Alias (Gen_Subp); 12745 12746 -- Test whether we have a corresponding primitive 12747 -- by comparing names, kinds, formal types, and 12748 -- result types. 12749 12750 if Chars (Anc_Subp) = Chars (Act_Subp) 12751 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 12752 then 12753 Anc_Formal := First_Formal (Anc_Subp); 12754 Act_Formal := First_Formal (Act_Subp); 12755 while Present (Anc_Formal) 12756 and then Present (Act_Formal) 12757 loop 12758 Anc_F_Type := Etype (Anc_Formal); 12759 Act_F_Type := Etype (Act_Formal); 12760 12761 if Ekind (Anc_F_Type) = 12762 E_Anonymous_Access_Type 12763 then 12764 Anc_F_Type := Designated_Type (Anc_F_Type); 12765 12766 if Ekind (Act_F_Type) = 12767 E_Anonymous_Access_Type 12768 then 12769 Act_F_Type := 12770 Designated_Type (Act_F_Type); 12771 else 12772 exit; 12773 end if; 12774 12775 elsif 12776 Ekind (Act_F_Type) = E_Anonymous_Access_Type 12777 then 12778 exit; 12779 end if; 12780 12781 Anc_F_Type := Base_Type (Anc_F_Type); 12782 Act_F_Type := Base_Type (Act_F_Type); 12783 12784 -- If the formal is controlling, then the 12785 -- the type of the actual primitive's formal 12786 -- must be derived directly or indirectly 12787 -- from the type of the ancestor primitive's 12788 -- formal. 12789 12790 if Is_Controlling_Formal (Anc_Formal) then 12791 if not Is_Tagged_Ancestor 12792 (Anc_F_Type, Act_F_Type) 12793 then 12794 exit; 12795 end if; 12796 12797 -- Otherwise the types of the formals must 12798 -- be the same. 12799 12800 elsif Anc_F_Type /= Act_F_Type then 12801 exit; 12802 end if; 12803 12804 Next_Entity (Anc_Formal); 12805 Next_Entity (Act_Formal); 12806 end loop; 12807 12808 -- If we traversed through all of the formals 12809 -- then so far the subprograms correspond, so 12810 -- now check that any result types correspond. 12811 12812 if No (Anc_Formal) and then No (Act_Formal) then 12813 Subprograms_Correspond := True; 12814 12815 if Ekind (Act_Subp) = E_Function then 12816 Anc_F_Type := Etype (Anc_Subp); 12817 Act_F_Type := Etype (Act_Subp); 12818 12819 if Ekind (Anc_F_Type) = 12820 E_Anonymous_Access_Type 12821 then 12822 Anc_F_Type := 12823 Designated_Type (Anc_F_Type); 12824 12825 if Ekind (Act_F_Type) = 12826 E_Anonymous_Access_Type 12827 then 12828 Act_F_Type := 12829 Designated_Type (Act_F_Type); 12830 else 12831 Subprograms_Correspond := False; 12832 end if; 12833 12834 elsif 12835 Ekind (Act_F_Type) 12836 = E_Anonymous_Access_Type 12837 then 12838 Subprograms_Correspond := False; 12839 end if; 12840 12841 Anc_F_Type := Base_Type (Anc_F_Type); 12842 Act_F_Type := Base_Type (Act_F_Type); 12843 12844 -- Now either the result types must be 12845 -- the same or, if the result type is 12846 -- controlling, the result type of the 12847 -- actual primitive must descend from the 12848 -- result type of the ancestor primitive. 12849 12850 if Subprograms_Correspond 12851 and then Anc_F_Type /= Act_F_Type 12852 and then 12853 Has_Controlling_Result (Anc_Subp) 12854 and then not Is_Tagged_Ancestor 12855 (Anc_F_Type, Act_F_Type) 12856 then 12857 Subprograms_Correspond := False; 12858 end if; 12859 end if; 12860 12861 -- Found a matching subprogram belonging to 12862 -- formal ancestor type, so actual subprogram 12863 -- corresponds and this violates 3.9.3(9). 12864 12865 if Subprograms_Correspond then 12866 Error_Msg_NE 12867 ("abstract subprogram & overrides " 12868 & "nonabstract subprogram of ancestor", 12869 Actual, Act_Subp); 12870 end if; 12871 end if; 12872 end if; 12873 end if; 12874 12875 Next_Elmt (Act_Elmt); 12876 end loop; 12877 end if; 12878 12879 Next_Elmt (Gen_Elmt); 12880 end loop; 12881 end Check_Abstract_Primitives; 12882 end if; 12883 12884 -- Verify that limitedness matches. If parent is a limited 12885 -- interface then the generic formal is not unless declared 12886 -- explicitly so. If not declared limited, the actual cannot be 12887 -- limited (see AI05-0087). 12888 12889 -- Even though this AI is a binding interpretation, we enable the 12890 -- check only in Ada 2012 mode, because this improper construct 12891 -- shows up in user code and in existing B-tests. 12892 12893 if Is_Limited_Type (Act_T) 12894 and then not Is_Limited_Type (A_Gen_T) 12895 and then Ada_Version >= Ada_2012 12896 then 12897 if In_Instance then 12898 null; 12899 else 12900 Error_Msg_NE 12901 ("actual for non-limited & cannot be a limited type", 12902 Actual, Gen_T); 12903 Explain_Limited_Type (Act_T, Actual); 12904 Abandon_Instantiation (Actual); 12905 end if; 12906 end if; 12907 end Validate_Derived_Type_Instance; 12908 12909 ---------------------------------------- 12910 -- Validate_Discriminated_Formal_Type -- 12911 ---------------------------------------- 12912 12913 procedure Validate_Discriminated_Formal_Type is 12914 Formal_Discr : Entity_Id; 12915 Actual_Discr : Entity_Id; 12916 Formal_Subt : Entity_Id; 12917 12918 begin 12919 if Has_Discriminants (A_Gen_T) then 12920 if not Has_Discriminants (Act_T) then 12921 Error_Msg_NE 12922 ("actual for & must have discriminants", Actual, Gen_T); 12923 Abandon_Instantiation (Actual); 12924 12925 elsif Is_Constrained (Act_T) then 12926 Error_Msg_NE 12927 ("actual for & must be unconstrained", Actual, Gen_T); 12928 Abandon_Instantiation (Actual); 12929 12930 else 12931 Formal_Discr := First_Discriminant (A_Gen_T); 12932 Actual_Discr := First_Discriminant (Act_T); 12933 while Formal_Discr /= Empty loop 12934 if Actual_Discr = Empty then 12935 Error_Msg_NE 12936 ("discriminants on actual do not match formal", 12937 Actual, Gen_T); 12938 Abandon_Instantiation (Actual); 12939 end if; 12940 12941 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 12942 12943 -- Access discriminants match if designated types do 12944 12945 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 12946 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 12947 E_Anonymous_Access_Type 12948 and then 12949 Get_Instance_Of 12950 (Designated_Type (Base_Type (Formal_Subt))) = 12951 Designated_Type (Base_Type (Etype (Actual_Discr))) 12952 then 12953 null; 12954 12955 elsif Base_Type (Formal_Subt) /= 12956 Base_Type (Etype (Actual_Discr)) 12957 then 12958 Error_Msg_NE 12959 ("types of actual discriminants must match formal", 12960 Actual, Gen_T); 12961 Abandon_Instantiation (Actual); 12962 12963 elsif not Subtypes_Statically_Match 12964 (Formal_Subt, Etype (Actual_Discr)) 12965 and then Ada_Version >= Ada_95 12966 then 12967 Error_Msg_NE 12968 ("subtypes of actual discriminants must match formal", 12969 Actual, Gen_T); 12970 Abandon_Instantiation (Actual); 12971 end if; 12972 12973 Next_Discriminant (Formal_Discr); 12974 Next_Discriminant (Actual_Discr); 12975 end loop; 12976 12977 if Actual_Discr /= Empty then 12978 Error_Msg_NE 12979 ("discriminants on actual do not match formal", 12980 Actual, Gen_T); 12981 Abandon_Instantiation (Actual); 12982 end if; 12983 end if; 12984 end if; 12985 end Validate_Discriminated_Formal_Type; 12986 12987 --------------------------------------- 12988 -- Validate_Incomplete_Type_Instance -- 12989 --------------------------------------- 12990 12991 procedure Validate_Incomplete_Type_Instance is 12992 begin 12993 if not Is_Tagged_Type (Act_T) 12994 and then Is_Tagged_Type (A_Gen_T) 12995 then 12996 Error_Msg_NE 12997 ("actual for & must be a tagged type", Actual, Gen_T); 12998 end if; 12999 13000 Validate_Discriminated_Formal_Type; 13001 end Validate_Incomplete_Type_Instance; 13002 13003 -------------------------------------- 13004 -- Validate_Interface_Type_Instance -- 13005 -------------------------------------- 13006 13007 procedure Validate_Interface_Type_Instance is 13008 begin 13009 if not Is_Interface (Act_T) then 13010 Error_Msg_NE 13011 ("actual for formal interface type must be an interface", 13012 Actual, Gen_T); 13013 13014 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 13015 or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 13016 or else Is_Protected_Interface (A_Gen_T) /= 13017 Is_Protected_Interface (Act_T) 13018 or else Is_Synchronized_Interface (A_Gen_T) /= 13019 Is_Synchronized_Interface (Act_T) 13020 then 13021 Error_Msg_NE 13022 ("actual for interface& does not match (RM 12.5.5(4))", 13023 Actual, Gen_T); 13024 end if; 13025 end Validate_Interface_Type_Instance; 13026 13027 ------------------------------------ 13028 -- Validate_Private_Type_Instance -- 13029 ------------------------------------ 13030 13031 procedure Validate_Private_Type_Instance is 13032 begin 13033 if Is_Limited_Type (Act_T) 13034 and then not Is_Limited_Type (A_Gen_T) 13035 then 13036 if In_Instance then 13037 null; 13038 else 13039 Error_Msg_NE 13040 ("actual for non-limited & cannot be a limited type", Actual, 13041 Gen_T); 13042 Explain_Limited_Type (Act_T, Actual); 13043 Abandon_Instantiation (Actual); 13044 end if; 13045 13046 elsif Known_To_Have_Preelab_Init (A_Gen_T) 13047 and then not Has_Preelaborable_Initialization (Act_T) 13048 then 13049 Error_Msg_NE 13050 ("actual for & must have preelaborable initialization", Actual, 13051 Gen_T); 13052 13053 elsif not Is_Definite_Subtype (Act_T) 13054 and then Is_Definite_Subtype (A_Gen_T) 13055 and then Ada_Version >= Ada_95 13056 then 13057 Error_Msg_NE 13058 ("actual for & must be a definite subtype", Actual, Gen_T); 13059 13060 elsif not Is_Tagged_Type (Act_T) 13061 and then Is_Tagged_Type (A_Gen_T) 13062 then 13063 Error_Msg_NE 13064 ("actual for & must be a tagged type", Actual, Gen_T); 13065 end if; 13066 13067 Validate_Discriminated_Formal_Type; 13068 Ancestor := Gen_T; 13069 end Validate_Private_Type_Instance; 13070 13071 -- Start of processing for Instantiate_Type 13072 13073 begin 13074 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 13075 Error_Msg_N ("duplicate instantiation of generic type", Actual); 13076 return New_List (Error); 13077 13078 elsif not Is_Entity_Name (Actual) 13079 or else not Is_Type (Entity (Actual)) 13080 then 13081 Error_Msg_NE 13082 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 13083 Abandon_Instantiation (Actual); 13084 13085 else 13086 Act_T := Entity (Actual); 13087 13088 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 13089 -- as a generic actual parameter if the corresponding formal type 13090 -- does not have a known_discriminant_part, or is a formal derived 13091 -- type that is an Unchecked_Union type. 13092 13093 if Is_Unchecked_Union (Base_Type (Act_T)) then 13094 if not Has_Discriminants (A_Gen_T) 13095 or else (Is_Derived_Type (A_Gen_T) 13096 and then Is_Unchecked_Union (A_Gen_T)) 13097 then 13098 null; 13099 else 13100 Error_Msg_N ("unchecked union cannot be the actual for a " 13101 & "discriminated formal type", Act_T); 13102 13103 end if; 13104 end if; 13105 13106 -- Deal with fixed/floating restrictions 13107 13108 if Is_Floating_Point_Type (Act_T) then 13109 Check_Restriction (No_Floating_Point, Actual); 13110 elsif Is_Fixed_Point_Type (Act_T) then 13111 Check_Restriction (No_Fixed_Point, Actual); 13112 end if; 13113 13114 -- Deal with error of using incomplete type as generic actual. 13115 -- This includes limited views of a type, even if the non-limited 13116 -- view may be available. 13117 13118 if Ekind (Act_T) = E_Incomplete_Type 13119 or else (Is_Class_Wide_Type (Act_T) 13120 and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 13121 then 13122 -- If the formal is an incomplete type, the actual can be 13123 -- incomplete as well. 13124 13125 if Ekind (A_Gen_T) = E_Incomplete_Type then 13126 null; 13127 13128 elsif Is_Class_Wide_Type (Act_T) 13129 or else No (Full_View (Act_T)) 13130 then 13131 Error_Msg_N ("premature use of incomplete type", Actual); 13132 Abandon_Instantiation (Actual); 13133 else 13134 Act_T := Full_View (Act_T); 13135 Set_Entity (Actual, Act_T); 13136 13137 if Has_Private_Component (Act_T) then 13138 Error_Msg_N 13139 ("premature use of type with private component", Actual); 13140 end if; 13141 end if; 13142 13143 -- Deal with error of premature use of private type as generic actual 13144 13145 elsif Is_Private_Type (Act_T) 13146 and then Is_Private_Type (Base_Type (Act_T)) 13147 and then not Is_Generic_Type (Act_T) 13148 and then not Is_Derived_Type (Act_T) 13149 and then No (Full_View (Root_Type (Act_T))) 13150 then 13151 -- If the formal is an incomplete type, the actual can be 13152 -- private or incomplete as well. 13153 13154 if Ekind (A_Gen_T) = E_Incomplete_Type then 13155 null; 13156 else 13157 Error_Msg_N ("premature use of private type", Actual); 13158 end if; 13159 13160 elsif Has_Private_Component (Act_T) then 13161 Error_Msg_N 13162 ("premature use of type with private component", Actual); 13163 end if; 13164 13165 Set_Instance_Of (A_Gen_T, Act_T); 13166 13167 -- If the type is generic, the class-wide type may also be used 13168 13169 if Is_Tagged_Type (A_Gen_T) 13170 and then Is_Tagged_Type (Act_T) 13171 and then not Is_Class_Wide_Type (A_Gen_T) 13172 then 13173 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 13174 Class_Wide_Type (Act_T)); 13175 end if; 13176 13177 if not Is_Abstract_Type (A_Gen_T) 13178 and then Is_Abstract_Type (Act_T) 13179 then 13180 Error_Msg_N 13181 ("actual of non-abstract formal cannot be abstract", Actual); 13182 end if; 13183 13184 -- A generic scalar type is a first subtype for which we generate 13185 -- an anonymous base type. Indicate that the instance of this base 13186 -- is the base type of the actual. 13187 13188 if Is_Scalar_Type (A_Gen_T) then 13189 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 13190 end if; 13191 end if; 13192 13193 if Error_Posted (Act_T) then 13194 null; 13195 else 13196 case Nkind (Def) is 13197 when N_Formal_Private_Type_Definition => 13198 Validate_Private_Type_Instance; 13199 13200 when N_Formal_Incomplete_Type_Definition => 13201 Validate_Incomplete_Type_Instance; 13202 13203 when N_Formal_Derived_Type_Definition => 13204 Validate_Derived_Type_Instance; 13205 13206 when N_Formal_Discrete_Type_Definition => 13207 if not Is_Discrete_Type (Act_T) then 13208 Error_Msg_NE 13209 ("expect discrete type in instantiation of&", 13210 Actual, Gen_T); 13211 Abandon_Instantiation (Actual); 13212 end if; 13213 13214 Diagnose_Predicated_Actual; 13215 13216 when N_Formal_Signed_Integer_Type_Definition => 13217 if not Is_Signed_Integer_Type (Act_T) then 13218 Error_Msg_NE 13219 ("expect signed integer type in instantiation of&", 13220 Actual, Gen_T); 13221 Abandon_Instantiation (Actual); 13222 end if; 13223 13224 Diagnose_Predicated_Actual; 13225 13226 when N_Formal_Modular_Type_Definition => 13227 if not Is_Modular_Integer_Type (Act_T) then 13228 Error_Msg_NE 13229 ("expect modular type in instantiation of &", 13230 Actual, Gen_T); 13231 Abandon_Instantiation (Actual); 13232 end if; 13233 13234 Diagnose_Predicated_Actual; 13235 13236 when N_Formal_Floating_Point_Definition => 13237 if not Is_Floating_Point_Type (Act_T) then 13238 Error_Msg_NE 13239 ("expect float type in instantiation of &", Actual, Gen_T); 13240 Abandon_Instantiation (Actual); 13241 end if; 13242 13243 when N_Formal_Ordinary_Fixed_Point_Definition => 13244 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 13245 Error_Msg_NE 13246 ("expect ordinary fixed point type in instantiation of &", 13247 Actual, Gen_T); 13248 Abandon_Instantiation (Actual); 13249 end if; 13250 13251 when N_Formal_Decimal_Fixed_Point_Definition => 13252 if not Is_Decimal_Fixed_Point_Type (Act_T) then 13253 Error_Msg_NE 13254 ("expect decimal type in instantiation of &", 13255 Actual, Gen_T); 13256 Abandon_Instantiation (Actual); 13257 end if; 13258 13259 when N_Array_Type_Definition => 13260 Validate_Array_Type_Instance; 13261 13262 when N_Access_To_Object_Definition => 13263 Validate_Access_Type_Instance; 13264 13265 when N_Access_Function_Definition 13266 | N_Access_Procedure_Definition 13267 => 13268 Validate_Access_Subprogram_Instance; 13269 13270 when N_Record_Definition => 13271 Validate_Interface_Type_Instance; 13272 13273 when N_Derived_Type_Definition => 13274 Validate_Derived_Interface_Type_Instance; 13275 13276 when others => 13277 raise Program_Error; 13278 end case; 13279 end if; 13280 13281 Subt := New_Copy (Gen_T); 13282 13283 -- Use adjusted sloc of subtype name as the location for other nodes in 13284 -- the subtype declaration. 13285 13286 Loc := Sloc (Subt); 13287 13288 Decl_Node := 13289 Make_Subtype_Declaration (Loc, 13290 Defining_Identifier => Subt, 13291 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); 13292 13293 if Is_Private_Type (Act_T) then 13294 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13295 13296 elsif Is_Access_Type (Act_T) 13297 and then Is_Private_Type (Designated_Type (Act_T)) 13298 then 13299 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13300 end if; 13301 13302 -- In Ada 2012 the actual may be a limited view. Indicate that 13303 -- the local subtype must be treated as such. 13304 13305 if From_Limited_With (Act_T) then 13306 Set_Ekind (Subt, E_Incomplete_Subtype); 13307 Set_From_Limited_With (Subt); 13308 end if; 13309 13310 Decl_Nodes := New_List (Decl_Node); 13311 13312 -- Flag actual derived types so their elaboration produces the 13313 -- appropriate renamings for the primitive operations of the ancestor. 13314 -- Flag actual for formal private types as well, to determine whether 13315 -- operations in the private part may override inherited operations. 13316 -- If the formal has an interface list, the ancestor is not the 13317 -- parent, but the analyzed formal that includes the interface 13318 -- operations of all its progenitors. 13319 13320 -- Same treatment for formal private types, so we can check whether the 13321 -- type is tagged limited when validating derivations in the private 13322 -- part. (See AI05-096). 13323 13324 if Nkind (Def) = N_Formal_Derived_Type_Definition then 13325 if Present (Interface_List (Def)) then 13326 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13327 else 13328 Set_Generic_Parent_Type (Decl_Node, Ancestor); 13329 end if; 13330 13331 elsif Nkind_In (Def, N_Formal_Private_Type_Definition, 13332 N_Formal_Incomplete_Type_Definition) 13333 then 13334 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13335 end if; 13336 13337 -- If the actual is a synchronized type that implements an interface, 13338 -- the primitive operations are attached to the corresponding record, 13339 -- and we have to treat it as an additional generic actual, so that its 13340 -- primitive operations become visible in the instance. The task or 13341 -- protected type itself does not carry primitive operations. 13342 13343 if Is_Concurrent_Type (Act_T) 13344 and then Is_Tagged_Type (Act_T) 13345 and then Present (Corresponding_Record_Type (Act_T)) 13346 and then Present (Ancestor) 13347 and then Is_Interface (Ancestor) 13348 then 13349 declare 13350 Corr_Rec : constant Entity_Id := 13351 Corresponding_Record_Type (Act_T); 13352 New_Corr : Entity_Id; 13353 Corr_Decl : Node_Id; 13354 13355 begin 13356 New_Corr := Make_Temporary (Loc, 'S'); 13357 Corr_Decl := 13358 Make_Subtype_Declaration (Loc, 13359 Defining_Identifier => New_Corr, 13360 Subtype_Indication => 13361 New_Occurrence_Of (Corr_Rec, Loc)); 13362 Append_To (Decl_Nodes, Corr_Decl); 13363 13364 if Ekind (Act_T) = E_Task_Type then 13365 Set_Ekind (Subt, E_Task_Subtype); 13366 else 13367 Set_Ekind (Subt, E_Protected_Subtype); 13368 end if; 13369 13370 Set_Corresponding_Record_Type (Subt, Corr_Rec); 13371 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 13372 Set_Generic_Parent_Type (Decl_Node, Empty); 13373 end; 13374 end if; 13375 13376 -- For a floating-point type, capture dimension info if any, because 13377 -- the generated subtype declaration does not come from source and 13378 -- will not process dimensions. 13379 13380 if Is_Floating_Point_Type (Act_T) then 13381 Copy_Dimensions (Act_T, Subt); 13382 end if; 13383 13384 return Decl_Nodes; 13385 end Instantiate_Type; 13386 13387 --------------------- 13388 -- Is_In_Main_Unit -- 13389 --------------------- 13390 13391 function Is_In_Main_Unit (N : Node_Id) return Boolean is 13392 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 13393 Current_Unit : Node_Id; 13394 13395 begin 13396 if Unum = Main_Unit then 13397 return True; 13398 13399 -- If the current unit is a subunit then it is either the main unit or 13400 -- is being compiled as part of the main unit. 13401 13402 elsif Nkind (N) = N_Compilation_Unit then 13403 return Nkind (Unit (N)) = N_Subunit; 13404 end if; 13405 13406 Current_Unit := Parent (N); 13407 while Present (Current_Unit) 13408 and then Nkind (Current_Unit) /= N_Compilation_Unit 13409 loop 13410 Current_Unit := Parent (Current_Unit); 13411 end loop; 13412 13413 -- The instantiation node is in the main unit, or else the current node 13414 -- (perhaps as the result of nested instantiations) is in the main unit, 13415 -- or in the declaration of the main unit, which in this last case must 13416 -- be a body. 13417 13418 return 13419 Current_Unit = Cunit (Main_Unit) 13420 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 13421 or else (Present (Current_Unit) 13422 and then Present (Library_Unit (Current_Unit)) 13423 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 13424 end Is_In_Main_Unit; 13425 13426 ---------------------------- 13427 -- Load_Parent_Of_Generic -- 13428 ---------------------------- 13429 13430 procedure Load_Parent_Of_Generic 13431 (N : Node_Id; 13432 Spec : Node_Id; 13433 Body_Optional : Boolean := False) 13434 is 13435 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 13436 Saved_Style_Check : constant Boolean := Style_Check; 13437 Saved_Warnings : constant Warning_Record := Save_Warnings; 13438 True_Parent : Node_Id; 13439 Inst_Node : Node_Id; 13440 OK : Boolean; 13441 Previous_Instances : constant Elist_Id := New_Elmt_List; 13442 13443 procedure Collect_Previous_Instances (Decls : List_Id); 13444 -- Collect all instantiations in the given list of declarations, that 13445 -- precede the generic that we need to load. If the bodies of these 13446 -- instantiations are available, we must analyze them, to ensure that 13447 -- the public symbols generated are the same when the unit is compiled 13448 -- to generate code, and when it is compiled in the context of a unit 13449 -- that needs a particular nested instance. This process is applied to 13450 -- both package and subprogram instances. 13451 13452 -------------------------------- 13453 -- Collect_Previous_Instances -- 13454 -------------------------------- 13455 13456 procedure Collect_Previous_Instances (Decls : List_Id) is 13457 Decl : Node_Id; 13458 13459 begin 13460 Decl := First (Decls); 13461 while Present (Decl) loop 13462 if Sloc (Decl) >= Sloc (Inst_Node) then 13463 return; 13464 13465 -- If Decl is an instantiation, then record it as requiring 13466 -- instantiation of the corresponding body, except if it is an 13467 -- abbreviated instantiation generated internally for conformance 13468 -- checking purposes only for the case of a formal package 13469 -- declared without a box (see Instantiate_Formal_Package). Such 13470 -- an instantiation does not generate any code (the actual code 13471 -- comes from actual) and thus does not need to be analyzed here. 13472 -- If the instantiation appears with a generic package body it is 13473 -- not analyzed here either. 13474 13475 elsif Nkind (Decl) = N_Package_Instantiation 13476 and then not Is_Internal (Defining_Entity (Decl)) 13477 then 13478 Append_Elmt (Decl, Previous_Instances); 13479 13480 -- For a subprogram instantiation, omit instantiations intrinsic 13481 -- operations (Unchecked_Conversions, etc.) that have no bodies. 13482 13483 elsif Nkind_In (Decl, N_Function_Instantiation, 13484 N_Procedure_Instantiation) 13485 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 13486 then 13487 Append_Elmt (Decl, Previous_Instances); 13488 13489 elsif Nkind (Decl) = N_Package_Declaration then 13490 Collect_Previous_Instances 13491 (Visible_Declarations (Specification (Decl))); 13492 Collect_Previous_Instances 13493 (Private_Declarations (Specification (Decl))); 13494 13495 -- Previous non-generic bodies may contain instances as well 13496 13497 elsif Nkind (Decl) = N_Package_Body 13498 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 13499 then 13500 Collect_Previous_Instances (Declarations (Decl)); 13501 13502 elsif Nkind (Decl) = N_Subprogram_Body 13503 and then not Acts_As_Spec (Decl) 13504 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 13505 then 13506 Collect_Previous_Instances (Declarations (Decl)); 13507 end if; 13508 13509 Next (Decl); 13510 end loop; 13511 end Collect_Previous_Instances; 13512 13513 -- Start of processing for Load_Parent_Of_Generic 13514 13515 begin 13516 if not In_Same_Source_Unit (N, Spec) 13517 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 13518 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 13519 and then not Is_In_Main_Unit (Spec)) 13520 then 13521 -- Find body of parent of spec, and analyze it. A special case arises 13522 -- when the parent is an instantiation, that is to say when we are 13523 -- currently instantiating a nested generic. In that case, there is 13524 -- no separate file for the body of the enclosing instance. Instead, 13525 -- the enclosing body must be instantiated as if it were a pending 13526 -- instantiation, in order to produce the body for the nested generic 13527 -- we require now. Note that in that case the generic may be defined 13528 -- in a package body, the instance defined in the same package body, 13529 -- and the original enclosing body may not be in the main unit. 13530 13531 Inst_Node := Empty; 13532 13533 True_Parent := Parent (Spec); 13534 while Present (True_Parent) 13535 and then Nkind (True_Parent) /= N_Compilation_Unit 13536 loop 13537 if Nkind (True_Parent) = N_Package_Declaration 13538 and then 13539 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 13540 then 13541 -- Parent is a compilation unit that is an instantiation. 13542 -- Instantiation node has been replaced with package decl. 13543 13544 Inst_Node := Original_Node (True_Parent); 13545 exit; 13546 13547 elsif Nkind (True_Parent) = N_Package_Declaration 13548 and then Present (Generic_Parent (Specification (True_Parent))) 13549 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13550 then 13551 -- Parent is an instantiation within another specification. 13552 -- Declaration for instance has been inserted before original 13553 -- instantiation node. A direct link would be preferable? 13554 13555 Inst_Node := Next (True_Parent); 13556 while Present (Inst_Node) 13557 and then Nkind (Inst_Node) /= N_Package_Instantiation 13558 loop 13559 Next (Inst_Node); 13560 end loop; 13561 13562 -- If the instance appears within a generic, and the generic 13563 -- unit is defined within a formal package of the enclosing 13564 -- generic, there is no generic body available, and none 13565 -- needed. A more precise test should be used ??? 13566 13567 if No (Inst_Node) then 13568 return; 13569 end if; 13570 13571 exit; 13572 13573 else 13574 True_Parent := Parent (True_Parent); 13575 end if; 13576 end loop; 13577 13578 -- Case where we are currently instantiating a nested generic 13579 13580 if Present (Inst_Node) then 13581 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 13582 13583 -- Instantiation node and declaration of instantiated package 13584 -- were exchanged when only the declaration was needed. 13585 -- Restore instantiation node before proceeding with body. 13586 13587 Set_Unit (Parent (True_Parent), Inst_Node); 13588 end if; 13589 13590 -- Now complete instantiation of enclosing body, if it appears in 13591 -- some other unit. If it appears in the current unit, the body 13592 -- will have been instantiated already. 13593 13594 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 13595 13596 -- We need to determine the expander mode to instantiate the 13597 -- enclosing body. Because the generic body we need may use 13598 -- global entities declared in the enclosing package (including 13599 -- aggregates) it is in general necessary to compile this body 13600 -- with expansion enabled, except if we are within a generic 13601 -- package, in which case the usual generic rule applies. 13602 13603 declare 13604 Exp_Status : Boolean := True; 13605 Scop : Entity_Id; 13606 13607 begin 13608 -- Loop through scopes looking for generic package 13609 13610 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 13611 while Present (Scop) 13612 and then Scop /= Standard_Standard 13613 loop 13614 if Ekind (Scop) = E_Generic_Package then 13615 Exp_Status := False; 13616 exit; 13617 end if; 13618 13619 Scop := Scope (Scop); 13620 end loop; 13621 13622 -- Collect previous instantiations in the unit that contains 13623 -- the desired generic. 13624 13625 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13626 and then not Body_Optional 13627 then 13628 declare 13629 Decl : Elmt_Id; 13630 Info : Pending_Body_Info; 13631 Par : Node_Id; 13632 13633 begin 13634 Par := Parent (Inst_Node); 13635 while Present (Par) loop 13636 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 13637 Par := Parent (Par); 13638 end loop; 13639 13640 pragma Assert (Present (Par)); 13641 13642 if Nkind (Par) = N_Package_Body then 13643 Collect_Previous_Instances (Declarations (Par)); 13644 13645 elsif Nkind (Par) = N_Package_Declaration then 13646 Collect_Previous_Instances 13647 (Visible_Declarations (Specification (Par))); 13648 Collect_Previous_Instances 13649 (Private_Declarations (Specification (Par))); 13650 13651 else 13652 -- Enclosing unit is a subprogram body. In this 13653 -- case all instance bodies are processed in order 13654 -- and there is no need to collect them separately. 13655 13656 null; 13657 end if; 13658 13659 Decl := First_Elmt (Previous_Instances); 13660 while Present (Decl) loop 13661 Info := 13662 (Inst_Node => Node (Decl), 13663 Act_Decl => 13664 Instance_Spec (Node (Decl)), 13665 Expander_Status => Exp_Status, 13666 Current_Sem_Unit => 13667 Get_Code_Unit (Sloc (Node (Decl))), 13668 Scope_Suppress => Scope_Suppress, 13669 Local_Suppress_Stack_Top => 13670 Local_Suppress_Stack_Top, 13671 Version => Ada_Version, 13672 Version_Pragma => Ada_Version_Pragma, 13673 Warnings => Save_Warnings, 13674 SPARK_Mode => SPARK_Mode, 13675 SPARK_Mode_Pragma => SPARK_Mode_Pragma); 13676 13677 -- Package instance 13678 13679 if Nkind (Node (Decl)) = N_Package_Instantiation 13680 then 13681 Instantiate_Package_Body 13682 (Info, Body_Optional => True); 13683 13684 -- Subprogram instance 13685 13686 else 13687 -- The instance_spec is in the wrapper package, 13688 -- usually followed by its local renaming 13689 -- declaration. See Build_Subprogram_Renaming 13690 -- for details. If the instance carries aspects, 13691 -- these result in the corresponding pragmas, 13692 -- inserted after the subprogram declaration. 13693 -- They must be skipped as well when retrieving 13694 -- the desired spec. Some of them may have been 13695 -- rewritten as null statements. 13696 -- A direct link would be more robust ??? 13697 13698 declare 13699 Decl : Node_Id := 13700 (Last (Visible_Declarations 13701 (Specification (Info.Act_Decl)))); 13702 begin 13703 while Nkind_In (Decl, 13704 N_Null_Statement, 13705 N_Pragma, 13706 N_Subprogram_Renaming_Declaration) 13707 loop 13708 Decl := Prev (Decl); 13709 end loop; 13710 13711 Info.Act_Decl := Decl; 13712 end; 13713 13714 Instantiate_Subprogram_Body 13715 (Info, Body_Optional => True); 13716 end if; 13717 13718 Next_Elmt (Decl); 13719 end loop; 13720 end; 13721 end if; 13722 13723 Instantiate_Package_Body 13724 (Body_Info => 13725 ((Inst_Node => Inst_Node, 13726 Act_Decl => True_Parent, 13727 Expander_Status => Exp_Status, 13728 Current_Sem_Unit => Get_Code_Unit 13729 (Sloc (Inst_Node)), 13730 Scope_Suppress => Scope_Suppress, 13731 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 13732 Version => Ada_Version, 13733 Version_Pragma => Ada_Version_Pragma, 13734 Warnings => Save_Warnings, 13735 SPARK_Mode => SPARK_Mode, 13736 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 13737 Body_Optional => Body_Optional); 13738 end; 13739 end if; 13740 13741 -- Case where we are not instantiating a nested generic 13742 13743 else 13744 Opt.Style_Check := False; 13745 Expander_Mode_Save_And_Set (True); 13746 Load_Needed_Body (Comp_Unit, OK); 13747 Opt.Style_Check := Saved_Style_Check; 13748 Restore_Warnings (Saved_Warnings); 13749 Expander_Mode_Restore; 13750 13751 if not OK 13752 and then Unit_Requires_Body (Defining_Entity (Spec)) 13753 and then not Body_Optional 13754 then 13755 declare 13756 Bname : constant Unit_Name_Type := 13757 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 13758 13759 begin 13760 -- In CodePeer mode, the missing body may make the analysis 13761 -- incomplete, but we do not treat it as fatal. 13762 13763 if CodePeer_Mode then 13764 return; 13765 13766 else 13767 Error_Msg_Unit_1 := Bname; 13768 Error_Msg_N ("this instantiation requires$!", N); 13769 Error_Msg_File_1 := 13770 Get_File_Name (Bname, Subunit => False); 13771 Error_Msg_N ("\but file{ was not found!", N); 13772 raise Unrecoverable_Error; 13773 end if; 13774 end; 13775 end if; 13776 end if; 13777 end if; 13778 13779 -- If loading parent of the generic caused an instantiation circularity, 13780 -- we abandon compilation at this point, because otherwise in some cases 13781 -- we get into trouble with infinite recursions after this point. 13782 13783 if Circularity_Detected then 13784 raise Unrecoverable_Error; 13785 end if; 13786 end Load_Parent_Of_Generic; 13787 13788 --------------------------------- 13789 -- Map_Formal_Package_Entities -- 13790 --------------------------------- 13791 13792 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 13793 E1 : Entity_Id; 13794 E2 : Entity_Id; 13795 13796 begin 13797 Set_Instance_Of (Form, Act); 13798 13799 -- Traverse formal and actual package to map the corresponding entities. 13800 -- We skip over internal entities that may be generated during semantic 13801 -- analysis, and find the matching entities by name, given that they 13802 -- must appear in the same order. 13803 13804 E1 := First_Entity (Form); 13805 E2 := First_Entity (Act); 13806 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 13807 -- Could this test be a single condition??? Seems like it could, and 13808 -- isn't FPE (Form) a constant anyway??? 13809 13810 if not Is_Internal (E1) 13811 and then Present (Parent (E1)) 13812 and then not Is_Class_Wide_Type (E1) 13813 and then not Is_Internal_Name (Chars (E1)) 13814 then 13815 while Present (E2) and then Chars (E2) /= Chars (E1) loop 13816 Next_Entity (E2); 13817 end loop; 13818 13819 if No (E2) then 13820 exit; 13821 else 13822 Set_Instance_Of (E1, E2); 13823 13824 if Is_Type (E1) and then Is_Tagged_Type (E2) then 13825 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 13826 end if; 13827 13828 if Is_Constrained (E1) then 13829 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 13830 end if; 13831 13832 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 13833 Map_Formal_Package_Entities (E1, E2); 13834 end if; 13835 end if; 13836 end if; 13837 13838 Next_Entity (E1); 13839 end loop; 13840 end Map_Formal_Package_Entities; 13841 13842 ----------------------- 13843 -- Move_Freeze_Nodes -- 13844 ----------------------- 13845 13846 procedure Move_Freeze_Nodes 13847 (Out_Of : Entity_Id; 13848 After : Node_Id; 13849 L : List_Id) 13850 is 13851 Decl : Node_Id; 13852 Next_Decl : Node_Id; 13853 Next_Node : Node_Id := After; 13854 Spec : Node_Id; 13855 13856 function Is_Outer_Type (T : Entity_Id) return Boolean; 13857 -- Check whether entity is declared in a scope external to that of the 13858 -- generic unit. 13859 13860 ------------------- 13861 -- Is_Outer_Type -- 13862 ------------------- 13863 13864 function Is_Outer_Type (T : Entity_Id) return Boolean is 13865 Scop : Entity_Id := Scope (T); 13866 13867 begin 13868 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 13869 return True; 13870 13871 else 13872 while Scop /= Standard_Standard loop 13873 if Scop = Out_Of then 13874 return False; 13875 else 13876 Scop := Scope (Scop); 13877 end if; 13878 end loop; 13879 13880 return True; 13881 end if; 13882 end Is_Outer_Type; 13883 13884 -- Start of processing for Move_Freeze_Nodes 13885 13886 begin 13887 if No (L) then 13888 return; 13889 end if; 13890 13891 -- First remove the freeze nodes that may appear before all other 13892 -- declarations. 13893 13894 Decl := First (L); 13895 while Present (Decl) 13896 and then Nkind (Decl) = N_Freeze_Entity 13897 and then Is_Outer_Type (Entity (Decl)) 13898 loop 13899 Decl := Remove_Head (L); 13900 Insert_After (Next_Node, Decl); 13901 Set_Analyzed (Decl, False); 13902 Next_Node := Decl; 13903 Decl := First (L); 13904 end loop; 13905 13906 -- Next scan the list of declarations and remove each freeze node that 13907 -- appears ahead of the current node. 13908 13909 while Present (Decl) loop 13910 while Present (Next (Decl)) 13911 and then Nkind (Next (Decl)) = N_Freeze_Entity 13912 and then Is_Outer_Type (Entity (Next (Decl))) 13913 loop 13914 Next_Decl := Remove_Next (Decl); 13915 Insert_After (Next_Node, Next_Decl); 13916 Set_Analyzed (Next_Decl, False); 13917 Next_Node := Next_Decl; 13918 end loop; 13919 13920 -- If the declaration is a nested package or concurrent type, then 13921 -- recurse. Nested generic packages will have been processed from the 13922 -- inside out. 13923 13924 case Nkind (Decl) is 13925 when N_Package_Declaration => 13926 Spec := Specification (Decl); 13927 13928 when N_Task_Type_Declaration => 13929 Spec := Task_Definition (Decl); 13930 13931 when N_Protected_Type_Declaration => 13932 Spec := Protected_Definition (Decl); 13933 13934 when others => 13935 Spec := Empty; 13936 end case; 13937 13938 if Present (Spec) then 13939 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 13940 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 13941 end if; 13942 13943 Next (Decl); 13944 end loop; 13945 end Move_Freeze_Nodes; 13946 13947 ---------------- 13948 -- Next_Assoc -- 13949 ---------------- 13950 13951 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 13952 begin 13953 return Generic_Renamings.Table (E).Next_In_HTable; 13954 end Next_Assoc; 13955 13956 ------------------------ 13957 -- Preanalyze_Actuals -- 13958 ------------------------ 13959 13960 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is 13961 Assoc : Node_Id; 13962 Act : Node_Id; 13963 Errs : constant Nat := Serious_Errors_Detected; 13964 13965 Cur : Entity_Id := Empty; 13966 -- Current homograph of the instance name 13967 13968 Vis : Boolean := False; 13969 -- Saved visibility status of the current homograph 13970 13971 begin 13972 Assoc := First (Generic_Associations (N)); 13973 13974 -- If the instance is a child unit, its name may hide an outer homonym, 13975 -- so make it invisible to perform name resolution on the actuals. 13976 13977 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 13978 and then Present 13979 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 13980 then 13981 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 13982 13983 if Is_Compilation_Unit (Cur) then 13984 Vis := Is_Immediately_Visible (Cur); 13985 Set_Is_Immediately_Visible (Cur, False); 13986 else 13987 Cur := Empty; 13988 end if; 13989 end if; 13990 13991 while Present (Assoc) loop 13992 if Nkind (Assoc) /= N_Others_Choice then 13993 Act := Explicit_Generic_Actual_Parameter (Assoc); 13994 13995 -- Within a nested instantiation, a defaulted actual is an empty 13996 -- association, so nothing to analyze. If the subprogram actual 13997 -- is an attribute, analyze prefix only, because actual is not a 13998 -- complete attribute reference. 13999 14000 -- If actual is an allocator, analyze expression only. The full 14001 -- analysis can generate code, and if instance is a compilation 14002 -- unit we have to wait until the package instance is installed 14003 -- to have a proper place to insert this code. 14004 14005 -- String literals may be operators, but at this point we do not 14006 -- know whether the actual is a formal subprogram or a string. 14007 14008 if No (Act) then 14009 null; 14010 14011 elsif Nkind (Act) = N_Attribute_Reference then 14012 Analyze (Prefix (Act)); 14013 14014 elsif Nkind (Act) = N_Explicit_Dereference then 14015 Analyze (Prefix (Act)); 14016 14017 elsif Nkind (Act) = N_Allocator then 14018 declare 14019 Expr : constant Node_Id := Expression (Act); 14020 14021 begin 14022 if Nkind (Expr) = N_Subtype_Indication then 14023 Analyze (Subtype_Mark (Expr)); 14024 14025 -- Analyze separately each discriminant constraint, when 14026 -- given with a named association. 14027 14028 declare 14029 Constr : Node_Id; 14030 14031 begin 14032 Constr := First (Constraints (Constraint (Expr))); 14033 while Present (Constr) loop 14034 if Nkind (Constr) = N_Discriminant_Association then 14035 Analyze (Expression (Constr)); 14036 else 14037 Analyze (Constr); 14038 end if; 14039 14040 Next (Constr); 14041 end loop; 14042 end; 14043 14044 else 14045 Analyze (Expr); 14046 end if; 14047 end; 14048 14049 elsif Nkind (Act) /= N_Operator_Symbol then 14050 Analyze (Act); 14051 14052 -- Within a package instance, mark actuals that are limited 14053 -- views, so their use can be moved to the body of the 14054 -- enclosing unit. 14055 14056 if Is_Entity_Name (Act) 14057 and then Is_Type (Entity (Act)) 14058 and then From_Limited_With (Entity (Act)) 14059 and then Present (Inst) 14060 then 14061 Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); 14062 end if; 14063 end if; 14064 14065 if Errs /= Serious_Errors_Detected then 14066 14067 -- Do a minimal analysis of the generic, to prevent spurious 14068 -- warnings complaining about the generic being unreferenced, 14069 -- before abandoning the instantiation. 14070 14071 Analyze (Name (N)); 14072 14073 if Is_Entity_Name (Name (N)) 14074 and then Etype (Name (N)) /= Any_Type 14075 then 14076 Generate_Reference (Entity (Name (N)), Name (N)); 14077 Set_Is_Instantiated (Entity (Name (N))); 14078 end if; 14079 14080 if Present (Cur) then 14081 14082 -- For the case of a child instance hiding an outer homonym, 14083 -- provide additional warning which might explain the error. 14084 14085 Set_Is_Immediately_Visible (Cur, Vis); 14086 Error_Msg_NE 14087 ("& hides outer unit with the same name??", 14088 N, Defining_Unit_Name (N)); 14089 end if; 14090 14091 Abandon_Instantiation (Act); 14092 end if; 14093 end if; 14094 14095 Next (Assoc); 14096 end loop; 14097 14098 if Present (Cur) then 14099 Set_Is_Immediately_Visible (Cur, Vis); 14100 end if; 14101 end Preanalyze_Actuals; 14102 14103 ------------------------------- 14104 -- Provide_Completing_Bodies -- 14105 ------------------------------- 14106 14107 procedure Provide_Completing_Bodies (N : Node_Id) is 14108 procedure Build_Completing_Body (Subp_Decl : Node_Id); 14109 -- Generate the completing body for subprogram declaration Subp_Decl 14110 14111 procedure Provide_Completing_Bodies_In (Decls : List_Id); 14112 -- Generating completing bodies for all subprograms found in declarative 14113 -- list Decls. 14114 14115 --------------------------- 14116 -- Build_Completing_Body -- 14117 --------------------------- 14118 14119 procedure Build_Completing_Body (Subp_Decl : Node_Id) is 14120 Loc : constant Source_Ptr := Sloc (Subp_Decl); 14121 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 14122 Spec : Node_Id; 14123 14124 begin 14125 -- Nothing to do if the subprogram already has a completing body 14126 14127 if Present (Corresponding_Body (Subp_Decl)) then 14128 return; 14129 14130 -- Mark the function as having a valid return statement even though 14131 -- the body contains a single raise statement. 14132 14133 elsif Ekind (Subp_Id) = E_Function then 14134 Set_Return_Present (Subp_Id); 14135 end if; 14136 14137 -- Clone the specification to obtain new entities and reset the only 14138 -- semantic field. 14139 14140 Spec := Copy_Subprogram_Spec (Specification (Subp_Decl)); 14141 Set_Generic_Parent (Spec, Empty); 14142 14143 -- Generate: 14144 -- function Func ... return ... is 14145 -- <or> 14146 -- procedure Proc ... is 14147 -- begin 14148 -- raise Program_Error with "access before elaboration"; 14149 -- edn Proc; 14150 14151 Insert_After_And_Analyze (Subp_Decl, 14152 Make_Subprogram_Body (Loc, 14153 Specification => Spec, 14154 Declarations => New_List, 14155 Handled_Statement_Sequence => 14156 Make_Handled_Sequence_Of_Statements (Loc, 14157 Statements => New_List ( 14158 Make_Raise_Program_Error (Loc, 14159 Reason => PE_Access_Before_Elaboration))))); 14160 end Build_Completing_Body; 14161 14162 ---------------------------------- 14163 -- Provide_Completing_Bodies_In -- 14164 ---------------------------------- 14165 14166 procedure Provide_Completing_Bodies_In (Decls : List_Id) is 14167 Decl : Node_Id; 14168 14169 begin 14170 if Present (Decls) then 14171 Decl := First (Decls); 14172 while Present (Decl) loop 14173 Provide_Completing_Bodies (Decl); 14174 Next (Decl); 14175 end loop; 14176 end if; 14177 end Provide_Completing_Bodies_In; 14178 14179 -- Local variables 14180 14181 Spec : Node_Id; 14182 14183 -- Start of processing for Provide_Completing_Bodies 14184 14185 begin 14186 if Nkind (N) = N_Package_Declaration then 14187 Spec := Specification (N); 14188 14189 Push_Scope (Defining_Entity (N)); 14190 Provide_Completing_Bodies_In (Visible_Declarations (Spec)); 14191 Provide_Completing_Bodies_In (Private_Declarations (Spec)); 14192 Pop_Scope; 14193 14194 elsif Nkind (N) = N_Subprogram_Declaration then 14195 Build_Completing_Body (N); 14196 end if; 14197 end Provide_Completing_Bodies; 14198 14199 ------------------- 14200 -- Remove_Parent -- 14201 ------------------- 14202 14203 procedure Remove_Parent (In_Body : Boolean := False) is 14204 S : Entity_Id := Current_Scope; 14205 -- S is the scope containing the instantiation just completed. The scope 14206 -- stack contains the parent instances of the instantiation, followed by 14207 -- the original S. 14208 14209 Cur_P : Entity_Id; 14210 E : Entity_Id; 14211 P : Entity_Id; 14212 Hidden : Elmt_Id; 14213 14214 begin 14215 -- After child instantiation is complete, remove from scope stack the 14216 -- extra copy of the current scope, and then remove parent instances. 14217 14218 if not In_Body then 14219 Pop_Scope; 14220 14221 while Current_Scope /= S loop 14222 P := Current_Scope; 14223 End_Package_Scope (Current_Scope); 14224 14225 if In_Open_Scopes (P) then 14226 E := First_Entity (P); 14227 while Present (E) loop 14228 Set_Is_Immediately_Visible (E, True); 14229 Next_Entity (E); 14230 end loop; 14231 14232 -- If instantiation is declared in a block, it is the enclosing 14233 -- scope that might be a parent instance. Note that only one 14234 -- block can be involved, because the parent instances have 14235 -- been installed within it. 14236 14237 if Ekind (P) = E_Block then 14238 Cur_P := Scope (P); 14239 else 14240 Cur_P := P; 14241 end if; 14242 14243 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 14244 -- We are within an instance of some sibling. Retain 14245 -- visibility of parent, for proper subsequent cleanup, and 14246 -- reinstall private declarations as well. 14247 14248 Set_In_Private_Part (P); 14249 Install_Private_Declarations (P); 14250 end if; 14251 14252 -- If the ultimate parent is a top-level unit recorded in 14253 -- Instance_Parent_Unit, then reset its visibility to what it was 14254 -- before instantiation. (It's not clear what the purpose is of 14255 -- testing whether Scope (P) is In_Open_Scopes, but that test was 14256 -- present before the ultimate parent test was added.???) 14257 14258 elsif not In_Open_Scopes (Scope (P)) 14259 or else (P = Instance_Parent_Unit 14260 and then not Parent_Unit_Visible) 14261 then 14262 Set_Is_Immediately_Visible (P, False); 14263 14264 -- If the current scope is itself an instantiation of a generic 14265 -- nested within P, and we are in the private part of body of this 14266 -- instantiation, restore the full views of P, that were removed 14267 -- in End_Package_Scope above. This obscure case can occur when a 14268 -- subunit of a generic contains an instance of a child unit of 14269 -- its generic parent unit. 14270 14271 elsif S = Current_Scope and then Is_Generic_Instance (S) then 14272 declare 14273 Par : constant Entity_Id := 14274 Generic_Parent (Package_Specification (S)); 14275 begin 14276 if Present (Par) 14277 and then P = Scope (Par) 14278 and then (In_Package_Body (S) or else In_Private_Part (S)) 14279 then 14280 Set_In_Private_Part (P); 14281 Install_Private_Declarations (P); 14282 end if; 14283 end; 14284 end if; 14285 end loop; 14286 14287 -- Reset visibility of entities in the enclosing scope 14288 14289 Set_Is_Hidden_Open_Scope (Current_Scope, False); 14290 14291 Hidden := First_Elmt (Hidden_Entities); 14292 while Present (Hidden) loop 14293 Set_Is_Immediately_Visible (Node (Hidden), True); 14294 Next_Elmt (Hidden); 14295 end loop; 14296 14297 else 14298 -- Each body is analyzed separately, and there is no context that 14299 -- needs preserving from one body instance to the next, so remove all 14300 -- parent scopes that have been installed. 14301 14302 while Present (S) loop 14303 End_Package_Scope (S); 14304 Set_Is_Immediately_Visible (S, False); 14305 S := Current_Scope; 14306 exit when S = Standard_Standard; 14307 end loop; 14308 end if; 14309 end Remove_Parent; 14310 14311 ----------------- 14312 -- Restore_Env -- 14313 ----------------- 14314 14315 procedure Restore_Env is 14316 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 14317 14318 begin 14319 if No (Current_Instantiated_Parent.Act_Id) then 14320 -- Restore environment after subprogram inlining 14321 14322 Restore_Private_Views (Empty); 14323 end if; 14324 14325 Current_Instantiated_Parent := Saved.Instantiated_Parent; 14326 Exchanged_Views := Saved.Exchanged_Views; 14327 Hidden_Entities := Saved.Hidden_Entities; 14328 Current_Sem_Unit := Saved.Current_Sem_Unit; 14329 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 14330 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 14331 14332 Restore_Opt_Config_Switches (Saved.Switches); 14333 14334 Instance_Envs.Decrement_Last; 14335 end Restore_Env; 14336 14337 --------------------------- 14338 -- Restore_Private_Views -- 14339 --------------------------- 14340 14341 procedure Restore_Private_Views 14342 (Pack_Id : Entity_Id; 14343 Is_Package : Boolean := True) 14344 is 14345 M : Elmt_Id; 14346 E : Entity_Id; 14347 Typ : Entity_Id; 14348 Dep_Elmt : Elmt_Id; 14349 Dep_Typ : Node_Id; 14350 14351 procedure Restore_Nested_Formal (Formal : Entity_Id); 14352 -- Hide the generic formals of formal packages declared with box which 14353 -- were reachable in the current instantiation. 14354 14355 --------------------------- 14356 -- Restore_Nested_Formal -- 14357 --------------------------- 14358 14359 procedure Restore_Nested_Formal (Formal : Entity_Id) is 14360 Ent : Entity_Id; 14361 14362 begin 14363 if Present (Renamed_Object (Formal)) 14364 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 14365 then 14366 return; 14367 14368 elsif Present (Associated_Formal_Package (Formal)) then 14369 Ent := First_Entity (Formal); 14370 while Present (Ent) loop 14371 exit when Ekind (Ent) = E_Package 14372 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 14373 14374 Set_Is_Hidden (Ent); 14375 Set_Is_Potentially_Use_Visible (Ent, False); 14376 14377 -- If package, then recurse 14378 14379 if Ekind (Ent) = E_Package then 14380 Restore_Nested_Formal (Ent); 14381 end if; 14382 14383 Next_Entity (Ent); 14384 end loop; 14385 end if; 14386 end Restore_Nested_Formal; 14387 14388 -- Start of processing for Restore_Private_Views 14389 14390 begin 14391 M := First_Elmt (Exchanged_Views); 14392 while Present (M) loop 14393 Typ := Node (M); 14394 14395 -- Subtypes of types whose views have been exchanged, and that are 14396 -- defined within the instance, were not on the Private_Dependents 14397 -- list on entry to the instance, so they have to be exchanged 14398 -- explicitly now, in order to remain consistent with the view of the 14399 -- parent type. 14400 14401 if Ekind_In (Typ, E_Private_Type, 14402 E_Limited_Private_Type, 14403 E_Record_Type_With_Private) 14404 then 14405 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 14406 while Present (Dep_Elmt) loop 14407 Dep_Typ := Node (Dep_Elmt); 14408 14409 if Scope (Dep_Typ) = Pack_Id 14410 and then Present (Full_View (Dep_Typ)) 14411 then 14412 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 14413 Exchange_Declarations (Dep_Typ); 14414 end if; 14415 14416 Next_Elmt (Dep_Elmt); 14417 end loop; 14418 end if; 14419 14420 Exchange_Declarations (Node (M)); 14421 Next_Elmt (M); 14422 end loop; 14423 14424 if No (Pack_Id) then 14425 return; 14426 end if; 14427 14428 -- Make the generic formal parameters private, and make the formal types 14429 -- into subtypes of the actuals again. 14430 14431 E := First_Entity (Pack_Id); 14432 while Present (E) loop 14433 Set_Is_Hidden (E, True); 14434 14435 if Is_Type (E) 14436 and then Nkind (Parent (E)) = N_Subtype_Declaration 14437 then 14438 -- If the actual for E is itself a generic actual type from 14439 -- an enclosing instance, E is still a generic actual type 14440 -- outside of the current instance. This matter when resolving 14441 -- an overloaded call that may be ambiguous in the enclosing 14442 -- instance, when two of its actuals coincide. 14443 14444 if Is_Entity_Name (Subtype_Indication (Parent (E))) 14445 and then Is_Generic_Actual_Type 14446 (Entity (Subtype_Indication (Parent (E)))) 14447 then 14448 null; 14449 else 14450 Set_Is_Generic_Actual_Type (E, False); 14451 end if; 14452 14453 -- An unusual case of aliasing: the actual may also be directly 14454 -- visible in the generic, and be private there, while it is fully 14455 -- visible in the context of the instance. The internal subtype 14456 -- is private in the instance but has full visibility like its 14457 -- parent in the enclosing scope. This enforces the invariant that 14458 -- the privacy status of all private dependents of a type coincide 14459 -- with that of the parent type. This can only happen when a 14460 -- generic child unit is instantiated within a sibling. 14461 14462 if Is_Private_Type (E) 14463 and then not Is_Private_Type (Etype (E)) 14464 then 14465 Exchange_Declarations (E); 14466 end if; 14467 14468 elsif Ekind (E) = E_Package then 14469 14470 -- The end of the renaming list is the renaming of the generic 14471 -- package itself. If the instance is a subprogram, all entities 14472 -- in the corresponding package are renamings. If this entity is 14473 -- a formal package, make its own formals private as well. The 14474 -- actual in this case is itself the renaming of an instantiation. 14475 -- If the entity is not a package renaming, it is the entity 14476 -- created to validate formal package actuals: ignore it. 14477 14478 -- If the actual is itself a formal package for the enclosing 14479 -- generic, or the actual for such a formal package, it remains 14480 -- visible on exit from the instance, and therefore nothing needs 14481 -- to be done either, except to keep it accessible. 14482 14483 if Is_Package and then Renamed_Object (E) = Pack_Id then 14484 exit; 14485 14486 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 14487 null; 14488 14489 elsif 14490 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 14491 then 14492 Set_Is_Hidden (E, False); 14493 14494 else 14495 declare 14496 Act_P : constant Entity_Id := Renamed_Object (E); 14497 Id : Entity_Id; 14498 14499 begin 14500 Id := First_Entity (Act_P); 14501 while Present (Id) 14502 and then Id /= First_Private_Entity (Act_P) 14503 loop 14504 exit when Ekind (Id) = E_Package 14505 and then Renamed_Object (Id) = Act_P; 14506 14507 Set_Is_Hidden (Id, True); 14508 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 14509 14510 if Ekind (Id) = E_Package then 14511 Restore_Nested_Formal (Id); 14512 end if; 14513 14514 Next_Entity (Id); 14515 end loop; 14516 end; 14517 end if; 14518 end if; 14519 14520 Next_Entity (E); 14521 end loop; 14522 end Restore_Private_Views; 14523 14524 -------------- 14525 -- Save_Env -- 14526 -------------- 14527 14528 procedure Save_Env 14529 (Gen_Unit : Entity_Id; 14530 Act_Unit : Entity_Id) 14531 is 14532 begin 14533 Init_Env; 14534 Set_Instance_Env (Gen_Unit, Act_Unit); 14535 end Save_Env; 14536 14537 ---------------------------- 14538 -- Save_Global_References -- 14539 ---------------------------- 14540 14541 procedure Save_Global_References (Templ : Node_Id) is 14542 14543 -- ??? it is horrible to use global variables in highly recursive code 14544 14545 E : Entity_Id; 14546 -- The entity of the current associated node 14547 14548 Gen_Scope : Entity_Id; 14549 -- The scope of the generic for which references are being saved 14550 14551 N2 : Node_Id; 14552 -- The current associated node 14553 14554 function Is_Global (E : Entity_Id) return Boolean; 14555 -- Check whether entity is defined outside of generic unit. Examine the 14556 -- scope of an entity, and the scope of the scope, etc, until we find 14557 -- either Standard, in which case the entity is global, or the generic 14558 -- unit itself, which indicates that the entity is local. If the entity 14559 -- is the generic unit itself, as in the case of a recursive call, or 14560 -- the enclosing generic unit, if different from the current scope, then 14561 -- it is local as well, because it will be replaced at the point of 14562 -- instantiation. On the other hand, if it is a reference to a child 14563 -- unit of a common ancestor, which appears in an instantiation, it is 14564 -- global because it is used to denote a specific compilation unit at 14565 -- the time the instantiations will be analyzed. 14566 14567 procedure Qualify_Universal_Operands 14568 (Op : Node_Id; 14569 Func_Call : Node_Id); 14570 -- Op denotes a binary or unary operator in generic template Templ. Node 14571 -- Func_Call is the function call alternative of the operator within the 14572 -- the analyzed copy of the template. Change each operand which yields a 14573 -- universal type by wrapping it into a qualified expression 14574 -- 14575 -- Actual_Typ'(Operand) 14576 -- 14577 -- where Actual_Typ is the type of corresponding actual parameter of 14578 -- Operand in Func_Call. 14579 14580 procedure Reset_Entity (N : Node_Id); 14581 -- Save semantic information on global entity so that it is not resolved 14582 -- again at instantiation time. 14583 14584 procedure Save_Entity_Descendants (N : Node_Id); 14585 -- Apply Save_Global_References to the two syntactic descendants of 14586 -- non-terminal nodes that carry an Associated_Node and are processed 14587 -- through Reset_Entity. Once the global entity (if any) has been 14588 -- captured together with its type, only two syntactic descendants need 14589 -- to be traversed to complete the processing of the tree rooted at N. 14590 -- This applies to Selected_Components, Expanded_Names, and to Operator 14591 -- nodes. N can also be a character literal, identifier, or operator 14592 -- symbol node, but the call has no effect in these cases. 14593 14594 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id); 14595 -- Default actuals in nested instances must be handled specially 14596 -- because there is no link to them from the original tree. When an 14597 -- actual subprogram is given by a default, we add an explicit generic 14598 -- association for it in the instantiation node. When we save the 14599 -- global references on the name of the instance, we recover the list 14600 -- of generic associations, and add an explicit one to the original 14601 -- generic tree, through which a global actual can be preserved. 14602 -- Similarly, if a child unit is instantiated within a sibling, in the 14603 -- context of the parent, we must preserve the identifier of the parent 14604 -- so that it can be properly resolved in a subsequent instantiation. 14605 14606 procedure Save_Global_Descendant (D : Union_Id); 14607 -- Apply Save_References recursively to the descendants of node D 14608 14609 procedure Save_References (N : Node_Id); 14610 -- This is the recursive procedure that does the work, once the 14611 -- enclosing generic scope has been established. 14612 14613 --------------- 14614 -- Is_Global -- 14615 --------------- 14616 14617 function Is_Global (E : Entity_Id) return Boolean is 14618 Se : Entity_Id; 14619 14620 function Is_Instance_Node (Decl : Node_Id) return Boolean; 14621 -- Determine whether the parent node of a reference to a child unit 14622 -- denotes an instantiation or a formal package, in which case the 14623 -- reference to the child unit is global, even if it appears within 14624 -- the current scope (e.g. when the instance appears within the body 14625 -- of an ancestor). 14626 14627 ---------------------- 14628 -- Is_Instance_Node -- 14629 ---------------------- 14630 14631 function Is_Instance_Node (Decl : Node_Id) return Boolean is 14632 begin 14633 return Nkind (Decl) in N_Generic_Instantiation 14634 or else 14635 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 14636 end Is_Instance_Node; 14637 14638 -- Start of processing for Is_Global 14639 14640 begin 14641 if E = Gen_Scope then 14642 return False; 14643 14644 elsif E = Standard_Standard then 14645 return True; 14646 14647 elsif Is_Child_Unit (E) 14648 and then (Is_Instance_Node (Parent (N2)) 14649 or else (Nkind (Parent (N2)) = N_Expanded_Name 14650 and then N2 = Selector_Name (Parent (N2)) 14651 and then 14652 Is_Instance_Node (Parent (Parent (N2))))) 14653 then 14654 return True; 14655 14656 else 14657 Se := Scope (E); 14658 while Se /= Gen_Scope loop 14659 if Se = Standard_Standard then 14660 return True; 14661 else 14662 Se := Scope (Se); 14663 end if; 14664 end loop; 14665 14666 return False; 14667 end if; 14668 end Is_Global; 14669 14670 -------------------------------- 14671 -- Qualify_Universal_Operands -- 14672 -------------------------------- 14673 14674 procedure Qualify_Universal_Operands 14675 (Op : Node_Id; 14676 Func_Call : Node_Id) 14677 is 14678 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id); 14679 -- Rewrite operand Opnd as a qualified expression of the form 14680 -- 14681 -- Actual_Typ'(Opnd) 14682 -- 14683 -- where Actual is the corresponding actual parameter of Opnd in 14684 -- function call Func_Call. 14685 14686 function Qualify_Type 14687 (Loc : Source_Ptr; 14688 Typ : Entity_Id) return Node_Id; 14689 -- Qualify type Typ by creating a selected component of the form 14690 -- 14691 -- Scope_Of_Typ.Typ 14692 14693 --------------------- 14694 -- Qualify_Operand -- 14695 --------------------- 14696 14697 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is 14698 Loc : constant Source_Ptr := Sloc (Opnd); 14699 Typ : constant Entity_Id := Etype (Actual); 14700 Mark : Node_Id; 14701 Qual : Node_Id; 14702 14703 begin 14704 -- Qualify the operand when it is of a universal type. Note that 14705 -- the template is unanalyzed and it is not possible to directly 14706 -- query the type. This transformation is not done when the type 14707 -- of the actual is internally generated because the type will be 14708 -- regenerated in the instance. 14709 14710 if Yields_Universal_Type (Opnd) 14711 and then Comes_From_Source (Typ) 14712 and then not Is_Hidden (Typ) 14713 then 14714 -- The type of the actual may be a global reference. Save this 14715 -- information by creating a reference to it. 14716 14717 if Is_Global (Typ) then 14718 Mark := New_Occurrence_Of (Typ, Loc); 14719 14720 -- Otherwise rely on resolution to find the proper type within 14721 -- the instance. 14722 14723 else 14724 Mark := Qualify_Type (Loc, Typ); 14725 end if; 14726 14727 Qual := 14728 Make_Qualified_Expression (Loc, 14729 Subtype_Mark => Mark, 14730 Expression => Relocate_Node (Opnd)); 14731 14732 -- Mark the qualification to distinguish it from other source 14733 -- constructs and signal the instantiation mechanism that this 14734 -- node requires special processing. See Copy_Generic_Node for 14735 -- details. 14736 14737 Set_Is_Qualified_Universal_Literal (Qual); 14738 14739 Rewrite (Opnd, Qual); 14740 end if; 14741 end Qualify_Operand; 14742 14743 ------------------ 14744 -- Qualify_Type -- 14745 ------------------ 14746 14747 function Qualify_Type 14748 (Loc : Source_Ptr; 14749 Typ : Entity_Id) return Node_Id 14750 is 14751 Scop : constant Entity_Id := Scope (Typ); 14752 Result : Node_Id; 14753 14754 begin 14755 Result := Make_Identifier (Loc, Chars (Typ)); 14756 14757 if Present (Scop) and then not Is_Generic_Unit (Scop) then 14758 Result := 14759 Make_Selected_Component (Loc, 14760 Prefix => Make_Identifier (Loc, Chars (Scop)), 14761 Selector_Name => Result); 14762 end if; 14763 14764 return Result; 14765 end Qualify_Type; 14766 14767 -- Local variables 14768 14769 Actuals : constant List_Id := Parameter_Associations (Func_Call); 14770 14771 -- Start of processing for Qualify_Universal_Operands 14772 14773 begin 14774 if Nkind (Op) in N_Binary_Op then 14775 Qualify_Operand (Left_Opnd (Op), First (Actuals)); 14776 Qualify_Operand (Right_Opnd (Op), Next (First (Actuals))); 14777 14778 elsif Nkind (Op) in N_Unary_Op then 14779 Qualify_Operand (Right_Opnd (Op), First (Actuals)); 14780 end if; 14781 end Qualify_Universal_Operands; 14782 14783 ------------------ 14784 -- Reset_Entity -- 14785 ------------------ 14786 14787 procedure Reset_Entity (N : Node_Id) is 14788 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 14789 -- If the type of N2 is global to the generic unit, save the type in 14790 -- the generic node. Just as we perform name capture for explicit 14791 -- references within the generic, we must capture the global types 14792 -- of local entities because they may participate in resolution in 14793 -- the instance. 14794 14795 function Top_Ancestor (E : Entity_Id) return Entity_Id; 14796 -- Find the ultimate ancestor of the current unit. If it is not a 14797 -- generic unit, then the name of the current unit in the prefix of 14798 -- an expanded name must be replaced with its generic homonym to 14799 -- ensure that it will be properly resolved in an instance. 14800 14801 --------------------- 14802 -- Set_Global_Type -- 14803 --------------------- 14804 14805 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 14806 Typ : constant Entity_Id := Etype (N2); 14807 14808 begin 14809 Set_Etype (N, Typ); 14810 14811 -- If the entity of N is not the associated node, this is a 14812 -- nested generic and it has an associated node as well, whose 14813 -- type is already the full view (see below). Indicate that the 14814 -- original node has a private view. 14815 14816 if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then 14817 Set_Has_Private_View (N); 14818 end if; 14819 14820 -- If not a private type, nothing else to do 14821 14822 if not Is_Private_Type (Typ) then 14823 if Is_Array_Type (Typ) 14824 and then Is_Private_Type (Component_Type (Typ)) 14825 then 14826 Set_Has_Private_View (N); 14827 end if; 14828 14829 -- If it is a derivation of a private type in a context where no 14830 -- full view is needed, nothing to do either. 14831 14832 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 14833 null; 14834 14835 -- Otherwise mark the type for flipping and use the full view when 14836 -- available. 14837 14838 else 14839 Set_Has_Private_View (N); 14840 14841 if Present (Full_View (Typ)) then 14842 Set_Etype (N2, Full_View (Typ)); 14843 end if; 14844 end if; 14845 14846 if Is_Floating_Point_Type (Typ) 14847 and then Has_Dimension_System (Typ) 14848 then 14849 Copy_Dimensions (N2, N); 14850 end if; 14851 end Set_Global_Type; 14852 14853 ------------------ 14854 -- Top_Ancestor -- 14855 ------------------ 14856 14857 function Top_Ancestor (E : Entity_Id) return Entity_Id is 14858 Par : Entity_Id; 14859 14860 begin 14861 Par := E; 14862 while Is_Child_Unit (Par) loop 14863 Par := Scope (Par); 14864 end loop; 14865 14866 return Par; 14867 end Top_Ancestor; 14868 14869 -- Start of processing for Reset_Entity 14870 14871 begin 14872 N2 := Get_Associated_Node (N); 14873 E := Entity (N2); 14874 14875 if Present (E) then 14876 14877 -- If the node is an entry call to an entry in an enclosing task, 14878 -- it is rewritten as a selected component. No global entity to 14879 -- preserve in this case, since the expansion will be redone in 14880 -- the instance. 14881 14882 if not Nkind_In (E, N_Defining_Character_Literal, 14883 N_Defining_Identifier, 14884 N_Defining_Operator_Symbol) 14885 then 14886 Set_Associated_Node (N, Empty); 14887 Set_Etype (N, Empty); 14888 return; 14889 end if; 14890 14891 -- If the entity is an itype created as a subtype of an access 14892 -- type with a null exclusion restore source entity for proper 14893 -- visibility. The itype will be created anew in the instance. 14894 14895 if Is_Itype (E) 14896 and then Ekind (E) = E_Access_Subtype 14897 and then Is_Entity_Name (N) 14898 and then Chars (Etype (E)) = Chars (N) 14899 then 14900 E := Etype (E); 14901 Set_Entity (N2, E); 14902 Set_Etype (N2, E); 14903 end if; 14904 14905 if Is_Global (E) then 14906 14907 -- If the entity is a package renaming that is the prefix of 14908 -- an expanded name, it has been rewritten as the renamed 14909 -- package, which is necessary semantically but complicates 14910 -- ASIS tree traversal, so we recover the original entity to 14911 -- expose the renaming. Take into account that the context may 14912 -- be a nested generic, that the original node may itself have 14913 -- an associated node that had better be an entity, and that 14914 -- the current node is still a selected component. 14915 14916 if Ekind (E) = E_Package 14917 and then Nkind (N) = N_Selected_Component 14918 and then Nkind (Parent (N)) = N_Expanded_Name 14919 and then Present (Original_Node (N2)) 14920 and then Is_Entity_Name (Original_Node (N2)) 14921 and then Present (Entity (Original_Node (N2))) 14922 then 14923 if Is_Global (Entity (Original_Node (N2))) then 14924 N2 := Original_Node (N2); 14925 Set_Associated_Node (N, N2); 14926 Set_Global_Type (N, N2); 14927 14928 -- Renaming is local, and will be resolved in instance 14929 14930 else 14931 Set_Associated_Node (N, Empty); 14932 Set_Etype (N, Empty); 14933 end if; 14934 14935 else 14936 Set_Global_Type (N, N2); 14937 end if; 14938 14939 elsif Nkind (N) = N_Op_Concat 14940 and then Is_Generic_Type (Etype (N2)) 14941 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 14942 or else 14943 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 14944 and then Is_Intrinsic_Subprogram (E) 14945 then 14946 null; 14947 14948 -- Entity is local. Mark generic node as unresolved. Note that now 14949 -- it does not have an entity. 14950 14951 else 14952 Set_Associated_Node (N, Empty); 14953 Set_Etype (N, Empty); 14954 end if; 14955 14956 if Nkind (Parent (N)) in N_Generic_Instantiation 14957 and then N = Name (Parent (N)) 14958 then 14959 Save_Global_Defaults (Parent (N), Parent (N2)); 14960 end if; 14961 14962 elsif Nkind (Parent (N)) = N_Selected_Component 14963 and then Nkind (Parent (N2)) = N_Expanded_Name 14964 then 14965 if Is_Global (Entity (Parent (N2))) then 14966 Change_Selected_Component_To_Expanded_Name (Parent (N)); 14967 Set_Associated_Node (Parent (N), Parent (N2)); 14968 Set_Global_Type (Parent (N), Parent (N2)); 14969 Save_Entity_Descendants (N); 14970 14971 -- If this is a reference to the current generic entity, replace 14972 -- by the name of the generic homonym of the current package. This 14973 -- is because in an instantiation Par.P.Q will not resolve to the 14974 -- name of the instance, whose enclosing scope is not necessarily 14975 -- Par. We use the generic homonym rather that the name of the 14976 -- generic itself because it may be hidden by a local declaration. 14977 14978 elsif In_Open_Scopes (Entity (Parent (N2))) 14979 and then not 14980 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 14981 then 14982 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 14983 Rewrite (Parent (N), 14984 Make_Identifier (Sloc (N), 14985 Chars => 14986 Chars (Generic_Homonym (Entity (Parent (N2)))))); 14987 else 14988 Rewrite (Parent (N), 14989 Make_Identifier (Sloc (N), 14990 Chars => Chars (Selector_Name (Parent (N2))))); 14991 end if; 14992 end if; 14993 14994 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 14995 and then Parent (N) = Name (Parent (Parent (N))) 14996 then 14997 Save_Global_Defaults 14998 (Parent (Parent (N)), Parent (Parent (N2))); 14999 end if; 15000 15001 -- A selected component may denote a static constant that has been 15002 -- folded. If the static constant is global to the generic, capture 15003 -- its value. Otherwise the folding will happen in any instantiation. 15004 15005 elsif Nkind (Parent (N)) = N_Selected_Component 15006 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 15007 then 15008 if Present (Entity (Original_Node (Parent (N2)))) 15009 and then Is_Global (Entity (Original_Node (Parent (N2)))) 15010 then 15011 Rewrite (Parent (N), New_Copy (Parent (N2))); 15012 Set_Analyzed (Parent (N), False); 15013 end if; 15014 15015 -- A selected component may be transformed into a parameterless 15016 -- function call. If the called entity is global, rewrite the node 15017 -- appropriately, i.e. as an extended name for the global entity. 15018 15019 elsif Nkind (Parent (N)) = N_Selected_Component 15020 and then Nkind (Parent (N2)) = N_Function_Call 15021 and then N = Selector_Name (Parent (N)) 15022 then 15023 if No (Parameter_Associations (Parent (N2))) then 15024 if Is_Global (Entity (Name (Parent (N2)))) then 15025 Change_Selected_Component_To_Expanded_Name (Parent (N)); 15026 Set_Associated_Node (Parent (N), Name (Parent (N2))); 15027 Set_Global_Type (Parent (N), Name (Parent (N2))); 15028 Save_Entity_Descendants (N); 15029 15030 else 15031 Set_Is_Prefixed_Call (Parent (N)); 15032 Set_Associated_Node (N, Empty); 15033 Set_Etype (N, Empty); 15034 end if; 15035 15036 -- In Ada 2005, X.F may be a call to a primitive operation, 15037 -- rewritten as F (X). This rewriting will be done again in an 15038 -- instance, so keep the original node. Global entities will be 15039 -- captured as for other constructs. Indicate that this must 15040 -- resolve as a call, to prevent accidental overloading in the 15041 -- instance, if both a component and a primitive operation appear 15042 -- as candidates. 15043 15044 else 15045 Set_Is_Prefixed_Call (Parent (N)); 15046 end if; 15047 15048 -- Entity is local. Reset in generic unit, so that node is resolved 15049 -- anew at the point of instantiation. 15050 15051 else 15052 Set_Associated_Node (N, Empty); 15053 Set_Etype (N, Empty); 15054 end if; 15055 end Reset_Entity; 15056 15057 ----------------------------- 15058 -- Save_Entity_Descendants -- 15059 ----------------------------- 15060 15061 procedure Save_Entity_Descendants (N : Node_Id) is 15062 begin 15063 case Nkind (N) is 15064 when N_Binary_Op => 15065 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 15066 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15067 15068 when N_Unary_Op => 15069 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15070 15071 when N_Expanded_Name 15072 | N_Selected_Component 15073 => 15074 Save_Global_Descendant (Union_Id (Prefix (N))); 15075 Save_Global_Descendant (Union_Id (Selector_Name (N))); 15076 15077 when N_Character_Literal 15078 | N_Identifier 15079 | N_Operator_Symbol 15080 => 15081 null; 15082 15083 when others => 15084 raise Program_Error; 15085 end case; 15086 end Save_Entity_Descendants; 15087 15088 -------------------------- 15089 -- Save_Global_Defaults -- 15090 -------------------------- 15091 15092 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id) is 15093 Loc : constant Source_Ptr := Sloc (N1); 15094 Assoc2 : constant List_Id := Generic_Associations (N2); 15095 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 15096 Assoc1 : List_Id; 15097 Act1 : Node_Id; 15098 Act2 : Node_Id; 15099 Def : Node_Id; 15100 Ndec : Node_Id; 15101 Subp : Entity_Id; 15102 Actual : Entity_Id; 15103 15104 begin 15105 Assoc1 := Generic_Associations (N1); 15106 15107 if Present (Assoc1) then 15108 Act1 := First (Assoc1); 15109 else 15110 Act1 := Empty; 15111 Set_Generic_Associations (N1, New_List); 15112 Assoc1 := Generic_Associations (N1); 15113 end if; 15114 15115 if Present (Assoc2) then 15116 Act2 := First (Assoc2); 15117 else 15118 return; 15119 end if; 15120 15121 while Present (Act1) and then Present (Act2) loop 15122 Next (Act1); 15123 Next (Act2); 15124 end loop; 15125 15126 -- Find the associations added for default subprograms 15127 15128 if Present (Act2) then 15129 while Nkind (Act2) /= N_Generic_Association 15130 or else No (Entity (Selector_Name (Act2))) 15131 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 15132 loop 15133 Next (Act2); 15134 end loop; 15135 15136 -- Add a similar association if the default is global. The 15137 -- renaming declaration for the actual has been analyzed, and 15138 -- its alias is the program it renames. Link the actual in the 15139 -- original generic tree with the node in the analyzed tree. 15140 15141 while Present (Act2) loop 15142 Subp := Entity (Selector_Name (Act2)); 15143 Def := Explicit_Generic_Actual_Parameter (Act2); 15144 15145 -- Following test is defence against rubbish errors 15146 15147 if No (Alias (Subp)) then 15148 return; 15149 end if; 15150 15151 -- Retrieve the resolved actual from the renaming declaration 15152 -- created for the instantiated formal. 15153 15154 Actual := Entity (Name (Parent (Parent (Subp)))); 15155 Set_Entity (Def, Actual); 15156 Set_Etype (Def, Etype (Actual)); 15157 15158 if Is_Global (Actual) then 15159 Ndec := 15160 Make_Generic_Association (Loc, 15161 Selector_Name => 15162 New_Occurrence_Of (Subp, Loc), 15163 Explicit_Generic_Actual_Parameter => 15164 New_Occurrence_Of (Actual, Loc)); 15165 15166 Set_Associated_Node 15167 (Explicit_Generic_Actual_Parameter (Ndec), Def); 15168 15169 Append (Ndec, Assoc1); 15170 15171 -- If there are other defaults, add a dummy association in case 15172 -- there are other defaulted formals with the same name. 15173 15174 elsif Present (Next (Act2)) then 15175 Ndec := 15176 Make_Generic_Association (Loc, 15177 Selector_Name => 15178 New_Occurrence_Of (Subp, Loc), 15179 Explicit_Generic_Actual_Parameter => Empty); 15180 15181 Append (Ndec, Assoc1); 15182 end if; 15183 15184 Next (Act2); 15185 end loop; 15186 end if; 15187 15188 if Nkind (Name (N1)) = N_Identifier 15189 and then Is_Child_Unit (Gen_Id) 15190 and then Is_Global (Gen_Id) 15191 and then Is_Generic_Unit (Scope (Gen_Id)) 15192 and then In_Open_Scopes (Scope (Gen_Id)) 15193 then 15194 -- This is an instantiation of a child unit within a sibling, so 15195 -- that the generic parent is in scope. An eventual instance must 15196 -- occur within the scope of an instance of the parent. Make name 15197 -- in instance into an expanded name, to preserve the identifier 15198 -- of the parent, so it can be resolved subsequently. 15199 15200 Rewrite (Name (N2), 15201 Make_Expanded_Name (Loc, 15202 Chars => Chars (Gen_Id), 15203 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15204 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15205 Set_Entity (Name (N2), Gen_Id); 15206 15207 Rewrite (Name (N1), 15208 Make_Expanded_Name (Loc, 15209 Chars => Chars (Gen_Id), 15210 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15211 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15212 15213 Set_Associated_Node (Name (N1), Name (N2)); 15214 Set_Associated_Node (Prefix (Name (N1)), Empty); 15215 Set_Associated_Node 15216 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 15217 Set_Etype (Name (N1), Etype (Gen_Id)); 15218 end if; 15219 end Save_Global_Defaults; 15220 15221 ---------------------------- 15222 -- Save_Global_Descendant -- 15223 ---------------------------- 15224 15225 procedure Save_Global_Descendant (D : Union_Id) is 15226 N1 : Node_Id; 15227 15228 begin 15229 if D in Node_Range then 15230 if D = Union_Id (Empty) then 15231 null; 15232 15233 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 15234 Save_References (Node_Id (D)); 15235 end if; 15236 15237 elsif D in List_Range then 15238 pragma Assert (D /= Union_Id (No_List)); 15239 -- Because No_List = Empty, which is in Node_Range above 15240 15241 if Is_Empty_List (List_Id (D)) then 15242 null; 15243 15244 else 15245 N1 := First (List_Id (D)); 15246 while Present (N1) loop 15247 Save_References (N1); 15248 Next (N1); 15249 end loop; 15250 end if; 15251 15252 -- Element list or other non-node field, nothing to do 15253 15254 else 15255 null; 15256 end if; 15257 end Save_Global_Descendant; 15258 15259 --------------------- 15260 -- Save_References -- 15261 --------------------- 15262 15263 -- This is the recursive procedure that does the work once the enclosing 15264 -- generic scope has been established. We have to treat specially a 15265 -- number of node rewritings that are required by semantic processing 15266 -- and which change the kind of nodes in the generic copy: typically 15267 -- constant-folding, replacing an operator node by a string literal, or 15268 -- a selected component by an expanded name. In each of those cases, the 15269 -- transformation is propagated to the generic unit. 15270 15271 procedure Save_References (N : Node_Id) is 15272 Loc : constant Source_Ptr := Sloc (N); 15273 15274 function Requires_Delayed_Save (Nod : Node_Id) return Boolean; 15275 -- Determine whether arbitrary node Nod requires delayed capture of 15276 -- global references within its aspect specifications. 15277 15278 procedure Save_References_In_Aggregate (N : Node_Id); 15279 -- Save all global references in [extension] aggregate node N 15280 15281 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id); 15282 -- Save all global references in a character literal or operator 15283 -- symbol denoted by N. 15284 15285 procedure Save_References_In_Descendants (N : Node_Id); 15286 -- Save all global references in all descendants of node N 15287 15288 procedure Save_References_In_Identifier (N : Node_Id); 15289 -- Save all global references in identifier node N 15290 15291 procedure Save_References_In_Operator (N : Node_Id); 15292 -- Save all global references in operator node N 15293 15294 procedure Save_References_In_Pragma (Prag : Node_Id); 15295 -- Save all global references found within the expression of pragma 15296 -- Prag. 15297 15298 --------------------------- 15299 -- Requires_Delayed_Save -- 15300 --------------------------- 15301 15302 function Requires_Delayed_Save (Nod : Node_Id) return Boolean is 15303 begin 15304 -- Generic packages and subprograms require delayed capture of 15305 -- global references within their aspects due to the timing of 15306 -- annotation analysis. 15307 15308 if Nkind_In (Nod, N_Generic_Package_Declaration, 15309 N_Generic_Subprogram_Declaration, 15310 N_Package_Body, 15311 N_Package_Body_Stub, 15312 N_Subprogram_Body, 15313 N_Subprogram_Body_Stub) 15314 then 15315 -- Since the capture of global references is done on the 15316 -- unanalyzed generic template, there is no information around 15317 -- to infer the context. Use the Associated_Entity linkages to 15318 -- peek into the analyzed generic copy and determine what the 15319 -- template corresponds to. 15320 15321 if Nod = Templ then 15322 return 15323 Is_Generic_Declaration_Or_Body 15324 (Unit_Declaration_Node 15325 (Associated_Entity (Defining_Entity (Nod)))); 15326 15327 -- Otherwise the generic unit being processed is not the top 15328 -- level template. It is safe to capture of global references 15329 -- within the generic unit because at this point the top level 15330 -- copy is fully analyzed. 15331 15332 else 15333 return False; 15334 end if; 15335 15336 -- Otherwise capture the global references without interference 15337 15338 else 15339 return False; 15340 end if; 15341 end Requires_Delayed_Save; 15342 15343 ---------------------------------- 15344 -- Save_References_In_Aggregate -- 15345 ---------------------------------- 15346 15347 procedure Save_References_In_Aggregate (N : Node_Id) is 15348 Nam : Node_Id; 15349 Qual : Node_Id := Empty; 15350 Typ : Entity_Id := Empty; 15351 15352 use Atree.Unchecked_Access; 15353 -- This code section is part of implementing an untyped tree 15354 -- traversal, so it needs direct access to node fields. 15355 15356 begin 15357 N2 := Get_Associated_Node (N); 15358 15359 if Present (N2) then 15360 Typ := Etype (N2); 15361 15362 -- In an instance within a generic, use the name of the actual 15363 -- and not the original generic parameter. If the actual is 15364 -- global in the current generic it must be preserved for its 15365 -- instantiation. 15366 15367 if Nkind (Parent (Typ)) = N_Subtype_Declaration 15368 and then Present (Generic_Parent_Type (Parent (Typ))) 15369 then 15370 Typ := Base_Type (Typ); 15371 Set_Etype (N2, Typ); 15372 end if; 15373 end if; 15374 15375 if No (N2) or else No (Typ) or else not Is_Global (Typ) then 15376 Set_Associated_Node (N, Empty); 15377 15378 -- If the aggregate is an actual in a call, it has been 15379 -- resolved in the current context, to some local type. The 15380 -- enclosing call may have been disambiguated by the aggregate, 15381 -- and this disambiguation might fail at instantiation time 15382 -- because the type to which the aggregate did resolve is not 15383 -- preserved. In order to preserve some of this information, 15384 -- wrap the aggregate in a qualified expression, using the id 15385 -- of its type. For further disambiguation we qualify the type 15386 -- name with its scope (if visible and not hidden by a local 15387 -- homograph) because both id's will have corresponding 15388 -- entities in an instance. This resolves most of the problems 15389 -- with missing type information on aggregates in instances. 15390 15391 if Present (N2) 15392 and then Nkind (N2) = Nkind (N) 15393 and then Nkind (Parent (N2)) in N_Subprogram_Call 15394 and then Present (Typ) 15395 and then Comes_From_Source (Typ) 15396 then 15397 Nam := Make_Identifier (Loc, Chars (Typ)); 15398 15399 if Is_Immediately_Visible (Scope (Typ)) 15400 and then 15401 (not In_Open_Scopes (Scope (Typ)) 15402 or else Current_Entity (Scope (Typ)) = Scope (Typ)) 15403 then 15404 Nam := 15405 Make_Selected_Component (Loc, 15406 Prefix => 15407 Make_Identifier (Loc, Chars (Scope (Typ))), 15408 Selector_Name => Nam); 15409 end if; 15410 15411 Qual := 15412 Make_Qualified_Expression (Loc, 15413 Subtype_Mark => Nam, 15414 Expression => Relocate_Node (N)); 15415 end if; 15416 end if; 15417 15418 Save_Global_Descendant (Field1 (N)); 15419 Save_Global_Descendant (Field2 (N)); 15420 Save_Global_Descendant (Field3 (N)); 15421 Save_Global_Descendant (Field5 (N)); 15422 15423 if Present (Qual) then 15424 Rewrite (N, Qual); 15425 end if; 15426 end Save_References_In_Aggregate; 15427 15428 ---------------------------------------------- 15429 -- Save_References_In_Char_Lit_Or_Op_Symbol -- 15430 ---------------------------------------------- 15431 15432 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id) is 15433 begin 15434 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15435 Reset_Entity (N); 15436 15437 elsif Nkind (N) = N_Operator_Symbol 15438 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 15439 then 15440 Change_Operator_Symbol_To_String_Literal (N); 15441 end if; 15442 end Save_References_In_Char_Lit_Or_Op_Symbol; 15443 15444 ------------------------------------ 15445 -- Save_References_In_Descendants -- 15446 ------------------------------------ 15447 15448 procedure Save_References_In_Descendants (N : Node_Id) is 15449 use Atree.Unchecked_Access; 15450 -- This code section is part of implementing an untyped tree 15451 -- traversal, so it needs direct access to node fields. 15452 15453 begin 15454 Save_Global_Descendant (Field1 (N)); 15455 Save_Global_Descendant (Field2 (N)); 15456 Save_Global_Descendant (Field3 (N)); 15457 Save_Global_Descendant (Field4 (N)); 15458 Save_Global_Descendant (Field5 (N)); 15459 end Save_References_In_Descendants; 15460 15461 ----------------------------------- 15462 -- Save_References_In_Identifier -- 15463 ----------------------------------- 15464 15465 procedure Save_References_In_Identifier (N : Node_Id) is 15466 begin 15467 -- The node did not undergo a transformation 15468 15469 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15470 declare 15471 Aux_N2 : constant Node_Id := Get_Associated_Node (N); 15472 Orig_N2_Parent : constant Node_Id := 15473 Original_Node (Parent (Aux_N2)); 15474 begin 15475 -- The parent of this identifier is a selected component 15476 -- which denotes a named number that was constant folded. 15477 -- Preserve the original name for ASIS and link the parent 15478 -- with its expanded name. The constant folding will be 15479 -- repeated in the instance. 15480 15481 if Nkind (Parent (N)) = N_Selected_Component 15482 and then Nkind_In (Parent (Aux_N2), N_Integer_Literal, 15483 N_Real_Literal) 15484 and then Is_Entity_Name (Orig_N2_Parent) 15485 and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind 15486 and then Is_Global (Entity (Orig_N2_Parent)) 15487 then 15488 N2 := Aux_N2; 15489 Set_Associated_Node 15490 (Parent (N), Original_Node (Parent (N2))); 15491 15492 -- Common case 15493 15494 else 15495 -- If this is a discriminant reference, always save it. 15496 -- It is used in the instance to find the corresponding 15497 -- discriminant positionally rather than by name. 15498 15499 Set_Original_Discriminant 15500 (N, Original_Discriminant (Get_Associated_Node (N))); 15501 end if; 15502 15503 Reset_Entity (N); 15504 end; 15505 15506 -- The analysis of the generic copy transformed the identifier 15507 -- into another construct. Propagate the changes to the template. 15508 15509 else 15510 N2 := Get_Associated_Node (N); 15511 15512 -- The identifier denotes a call to a parameterless function. 15513 -- Mark the node as resolved when the function is external. 15514 15515 if Nkind (N2) = N_Function_Call then 15516 E := Entity (Name (N2)); 15517 15518 if Present (E) and then Is_Global (E) then 15519 Set_Etype (N, Etype (N2)); 15520 else 15521 Set_Associated_Node (N, Empty); 15522 Set_Etype (N, Empty); 15523 end if; 15524 15525 -- The identifier denotes a named number that was constant 15526 -- folded. Preserve the original name for ASIS and undo the 15527 -- constant folding which will be repeated in the instance. 15528 15529 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 15530 and then Is_Entity_Name (Original_Node (N2)) 15531 then 15532 Set_Associated_Node (N, Original_Node (N2)); 15533 Reset_Entity (N); 15534 15535 -- The identifier resolved to a string literal. Propagate this 15536 -- information to the generic template. 15537 15538 elsif Nkind (N2) = N_String_Literal then 15539 Rewrite (N, New_Copy (N2)); 15540 15541 -- The identifier is rewritten as a dereference if it is the 15542 -- prefix of an implicit dereference. Preserve the original 15543 -- tree as the analysis of the instance will expand the node 15544 -- again, but preserve the resolved entity if it is global. 15545 15546 elsif Nkind (N2) = N_Explicit_Dereference then 15547 if Is_Entity_Name (Prefix (N2)) 15548 and then Present (Entity (Prefix (N2))) 15549 and then Is_Global (Entity (Prefix (N2))) 15550 then 15551 Set_Associated_Node (N, Prefix (N2)); 15552 15553 elsif Nkind (Prefix (N2)) = N_Function_Call 15554 and then Present (Entity (Name (Prefix (N2)))) 15555 and then Is_Global (Entity (Name (Prefix (N2)))) 15556 then 15557 Rewrite (N, 15558 Make_Explicit_Dereference (Loc, 15559 Prefix => 15560 Make_Function_Call (Loc, 15561 Name => 15562 New_Occurrence_Of 15563 (Entity (Name (Prefix (N2))), Loc)))); 15564 15565 else 15566 Set_Associated_Node (N, Empty); 15567 Set_Etype (N, Empty); 15568 end if; 15569 15570 -- The subtype mark of a nominally unconstrained object is 15571 -- rewritten as a subtype indication using the bounds of the 15572 -- expression. Recover the original subtype mark. 15573 15574 elsif Nkind (N2) = N_Subtype_Indication 15575 and then Is_Entity_Name (Original_Node (N2)) 15576 then 15577 Set_Associated_Node (N, Original_Node (N2)); 15578 Reset_Entity (N); 15579 end if; 15580 end if; 15581 end Save_References_In_Identifier; 15582 15583 --------------------------------- 15584 -- Save_References_In_Operator -- 15585 --------------------------------- 15586 15587 procedure Save_References_In_Operator (N : Node_Id) is 15588 begin 15589 -- The node did not undergo a transformation 15590 15591 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15592 if Nkind (N) = N_Op_Concat then 15593 Set_Is_Component_Left_Opnd (N, 15594 Is_Component_Left_Opnd (Get_Associated_Node (N))); 15595 15596 Set_Is_Component_Right_Opnd (N, 15597 Is_Component_Right_Opnd (Get_Associated_Node (N))); 15598 end if; 15599 15600 Reset_Entity (N); 15601 15602 -- The analysis of the generic copy transformed the operator into 15603 -- some other construct. Propagate the changes to the template if 15604 -- applicable. 15605 15606 else 15607 N2 := Get_Associated_Node (N); 15608 15609 -- The operator resoved to a function call 15610 15611 if Nkind (N2) = N_Function_Call then 15612 15613 -- Add explicit qualifications in the generic template for 15614 -- all operands of universal type. This aids resolution by 15615 -- preserving the actual type of a literal or an attribute 15616 -- that yields a universal result. 15617 15618 Qualify_Universal_Operands (N, N2); 15619 15620 E := Entity (Name (N2)); 15621 15622 if Present (E) and then Is_Global (E) then 15623 Set_Etype (N, Etype (N2)); 15624 else 15625 Set_Associated_Node (N, Empty); 15626 Set_Etype (N, Empty); 15627 end if; 15628 15629 -- The operator was folded into a literal 15630 15631 elsif Nkind_In (N2, N_Integer_Literal, 15632 N_Real_Literal, 15633 N_String_Literal) 15634 then 15635 if Present (Original_Node (N2)) 15636 and then Nkind (Original_Node (N2)) = Nkind (N) 15637 then 15638 -- Operation was constant-folded. Whenever possible, 15639 -- recover semantic information from unfolded node, 15640 -- for ASIS use. 15641 15642 Set_Associated_Node (N, Original_Node (N2)); 15643 15644 if Nkind (N) = N_Op_Concat then 15645 Set_Is_Component_Left_Opnd (N, 15646 Is_Component_Left_Opnd (Get_Associated_Node (N))); 15647 Set_Is_Component_Right_Opnd (N, 15648 Is_Component_Right_Opnd (Get_Associated_Node (N))); 15649 end if; 15650 15651 Reset_Entity (N); 15652 15653 -- Propagate the constant folding back to the template 15654 15655 else 15656 Rewrite (N, New_Copy (N2)); 15657 Set_Analyzed (N, False); 15658 end if; 15659 15660 -- The operator was folded into an enumeration literal. Retain 15661 -- the entity to avoid spurious ambiguities if it is overloaded 15662 -- at the point of instantiation or inlining. 15663 15664 elsif Nkind (N2) = N_Identifier 15665 and then Ekind (Entity (N2)) = E_Enumeration_Literal 15666 then 15667 Rewrite (N, New_Copy (N2)); 15668 Set_Analyzed (N, False); 15669 end if; 15670 end if; 15671 15672 -- Complete the operands check if node has not been constant 15673 -- folded. 15674 15675 if Nkind (N) in N_Op then 15676 Save_Entity_Descendants (N); 15677 end if; 15678 end Save_References_In_Operator; 15679 15680 ------------------------------- 15681 -- Save_References_In_Pragma -- 15682 ------------------------------- 15683 15684 procedure Save_References_In_Pragma (Prag : Node_Id) is 15685 Context : Node_Id; 15686 Do_Save : Boolean := True; 15687 15688 use Atree.Unchecked_Access; 15689 -- This code section is part of implementing an untyped tree 15690 -- traversal, so it needs direct access to node fields. 15691 15692 begin 15693 -- Do not save global references in pragmas generated from aspects 15694 -- because the pragmas will be regenerated at instantiation time. 15695 15696 if From_Aspect_Specification (Prag) then 15697 Do_Save := False; 15698 15699 -- The capture of global references within contract-related source 15700 -- pragmas associated with generic packages, subprograms or their 15701 -- respective bodies must be delayed due to timing of annotation 15702 -- analysis. Global references are still captured in routine 15703 -- Save_Global_References_In_Contract. 15704 15705 elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then 15706 if Is_Package_Contract_Annotation (Prag) then 15707 Context := Find_Related_Package_Or_Body (Prag); 15708 else 15709 pragma Assert (Is_Subprogram_Contract_Annotation (Prag)); 15710 Context := Find_Related_Declaration_Or_Body (Prag); 15711 end if; 15712 15713 -- The use of Original_Node accounts for the case when the 15714 -- related context is generic template. 15715 15716 if Requires_Delayed_Save (Original_Node (Context)) then 15717 Do_Save := False; 15718 end if; 15719 end if; 15720 15721 -- For all other cases, save all global references within the 15722 -- descendants, but skip the following semantic fields: 15723 15724 -- Field1 - Next_Pragma 15725 -- Field3 - Corresponding_Aspect 15726 -- Field5 - Next_Rep_Item 15727 15728 if Do_Save then 15729 Save_Global_Descendant (Field2 (Prag)); 15730 Save_Global_Descendant (Field4 (Prag)); 15731 end if; 15732 end Save_References_In_Pragma; 15733 15734 -- Start of processing for Save_References 15735 15736 begin 15737 if N = Empty then 15738 null; 15739 15740 -- Aggregates 15741 15742 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 15743 Save_References_In_Aggregate (N); 15744 15745 -- Character literals, operator symbols 15746 15747 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 15748 Save_References_In_Char_Lit_Or_Op_Symbol (N); 15749 15750 -- Defining identifiers 15751 15752 elsif Nkind (N) in N_Entity then 15753 null; 15754 15755 -- Identifiers 15756 15757 elsif Nkind (N) = N_Identifier then 15758 Save_References_In_Identifier (N); 15759 15760 -- Operators 15761 15762 elsif Nkind (N) in N_Op then 15763 Save_References_In_Operator (N); 15764 15765 -- Pragmas 15766 15767 elsif Nkind (N) = N_Pragma then 15768 Save_References_In_Pragma (N); 15769 15770 else 15771 Save_References_In_Descendants (N); 15772 end if; 15773 15774 -- Save all global references found within the aspect specifications 15775 -- of the related node. 15776 15777 if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then 15778 15779 -- The capture of global references within aspects associated with 15780 -- generic packages, subprograms or their bodies must be delayed 15781 -- due to timing of annotation analysis. Global references are 15782 -- still captured in routine Save_Global_References_In_Contract. 15783 15784 if Requires_Delayed_Save (N) then 15785 null; 15786 15787 -- Otherwise save all global references within the aspects 15788 15789 else 15790 Save_Global_References_In_Aspects (N); 15791 end if; 15792 end if; 15793 end Save_References; 15794 15795 -- Start of processing for Save_Global_References 15796 15797 begin 15798 Gen_Scope := Current_Scope; 15799 15800 -- If the generic unit is a child unit, references to entities in the 15801 -- parent are treated as local, because they will be resolved anew in 15802 -- the context of the instance of the parent. 15803 15804 while Is_Child_Unit (Gen_Scope) 15805 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 15806 loop 15807 Gen_Scope := Scope (Gen_Scope); 15808 end loop; 15809 15810 Save_References (Templ); 15811 end Save_Global_References; 15812 15813 --------------------------------------- 15814 -- Save_Global_References_In_Aspects -- 15815 --------------------------------------- 15816 15817 procedure Save_Global_References_In_Aspects (N : Node_Id) is 15818 Asp : Node_Id; 15819 Expr : Node_Id; 15820 15821 begin 15822 Asp := First (Aspect_Specifications (N)); 15823 while Present (Asp) loop 15824 Expr := Expression (Asp); 15825 15826 if Present (Expr) then 15827 Save_Global_References (Expr); 15828 end if; 15829 15830 Next (Asp); 15831 end loop; 15832 end Save_Global_References_In_Aspects; 15833 15834 ------------------------------------------ 15835 -- Set_Copied_Sloc_For_Inherited_Pragma -- 15836 ------------------------------------------ 15837 15838 procedure Set_Copied_Sloc_For_Inherited_Pragma 15839 (N : Node_Id; 15840 E : Entity_Id) 15841 is 15842 begin 15843 Create_Instantiation_Source (N, E, 15844 Inlined_Body => False, 15845 Inherited_Pragma => True, 15846 Factor => S_Adjustment); 15847 end Set_Copied_Sloc_For_Inherited_Pragma; 15848 15849 -------------------------------------- 15850 -- Set_Copied_Sloc_For_Inlined_Body -- 15851 -------------------------------------- 15852 15853 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 15854 begin 15855 Create_Instantiation_Source (N, E, 15856 Inlined_Body => True, 15857 Inherited_Pragma => False, 15858 Factor => S_Adjustment); 15859 end Set_Copied_Sloc_For_Inlined_Body; 15860 15861 --------------------- 15862 -- Set_Instance_Of -- 15863 --------------------- 15864 15865 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 15866 begin 15867 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 15868 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 15869 Generic_Renamings.Increment_Last; 15870 end Set_Instance_Of; 15871 15872 -------------------- 15873 -- Set_Next_Assoc -- 15874 -------------------- 15875 15876 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 15877 begin 15878 Generic_Renamings.Table (E).Next_In_HTable := Next; 15879 end Set_Next_Assoc; 15880 15881 ------------------- 15882 -- Start_Generic -- 15883 ------------------- 15884 15885 procedure Start_Generic is 15886 begin 15887 -- ??? More things could be factored out in this routine. 15888 -- Should probably be done at a later stage. 15889 15890 Generic_Flags.Append (Inside_A_Generic); 15891 Inside_A_Generic := True; 15892 15893 Expander_Mode_Save_And_Set (False); 15894 end Start_Generic; 15895 15896 ---------------------- 15897 -- Set_Instance_Env -- 15898 ---------------------- 15899 15900 -- WARNING: This routine manages SPARK regions 15901 15902 procedure Set_Instance_Env 15903 (Gen_Unit : Entity_Id; 15904 Act_Unit : Entity_Id) 15905 is 15906 Saved_AE : constant Boolean := Assertions_Enabled; 15907 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 15908 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 15909 -- Save the SPARK mode-related data because utilizing the configuration 15910 -- values of pragmas and switches will eliminate any previously set 15911 -- SPARK_Mode. 15912 15913 begin 15914 -- Regardless of the current mode, predefined units are analyzed in the 15915 -- most current Ada mode, and earlier version Ada checks do not apply 15916 -- to predefined units. Nothing needs to be done for non-internal units. 15917 -- These are always analyzed in the current mode. 15918 15919 if In_Internal_Unit (Gen_Unit) then 15920 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); 15921 15922 -- In Ada2012 we may want to enable assertions in an instance of a 15923 -- predefined unit, in which case we need to preserve the current 15924 -- setting for the Assertions_Enabled flag. This will become more 15925 -- critical when pre/postconditions are added to predefined units, 15926 -- as is already the case for some numeric libraries. 15927 15928 if Ada_Version >= Ada_2012 then 15929 Assertions_Enabled := Saved_AE; 15930 end if; 15931 15932 -- Reinstall the SPARK_Mode which was in effect at the point of 15933 -- instantiation. 15934 15935 Install_SPARK_Mode (Saved_SM, Saved_SMP); 15936 end if; 15937 15938 Current_Instantiated_Parent := 15939 (Gen_Id => Gen_Unit, 15940 Act_Id => Act_Unit, 15941 Next_In_HTable => Assoc_Null); 15942 end Set_Instance_Env; 15943 15944 ----------------- 15945 -- Switch_View -- 15946 ----------------- 15947 15948 procedure Switch_View (T : Entity_Id) is 15949 BT : constant Entity_Id := Base_Type (T); 15950 Priv_Elmt : Elmt_Id := No_Elmt; 15951 Priv_Sub : Entity_Id; 15952 15953 begin 15954 -- T may be private but its base type may have been exchanged through 15955 -- some other occurrence, in which case there is nothing to switch 15956 -- besides T itself. Note that a private dependent subtype of a private 15957 -- type might not have been switched even if the base type has been, 15958 -- because of the last branch of Check_Private_View (see comment there). 15959 15960 if not Is_Private_Type (BT) then 15961 Prepend_Elmt (Full_View (T), Exchanged_Views); 15962 Exchange_Declarations (T); 15963 return; 15964 end if; 15965 15966 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 15967 15968 if Present (Full_View (BT)) then 15969 Prepend_Elmt (Full_View (BT), Exchanged_Views); 15970 Exchange_Declarations (BT); 15971 end if; 15972 15973 while Present (Priv_Elmt) loop 15974 Priv_Sub := (Node (Priv_Elmt)); 15975 15976 -- We avoid flipping the subtype if the Etype of its full view is 15977 -- private because this would result in a malformed subtype. This 15978 -- occurs when the Etype of the subtype full view is the full view of 15979 -- the base type (and since the base types were just switched, the 15980 -- subtype is pointing to the wrong view). This is currently the case 15981 -- for tagged record types, access types (maybe more?) and needs to 15982 -- be resolved. ??? 15983 15984 if Present (Full_View (Priv_Sub)) 15985 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 15986 then 15987 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 15988 Exchange_Declarations (Priv_Sub); 15989 end if; 15990 15991 Next_Elmt (Priv_Elmt); 15992 end loop; 15993 end Switch_View; 15994 15995 ----------------- 15996 -- True_Parent -- 15997 ----------------- 15998 15999 function True_Parent (N : Node_Id) return Node_Id is 16000 begin 16001 if Nkind (Parent (N)) = N_Subunit then 16002 return Parent (Corresponding_Stub (Parent (N))); 16003 else 16004 return Parent (N); 16005 end if; 16006 end True_Parent; 16007 16008 ----------------------------- 16009 -- Valid_Default_Attribute -- 16010 ----------------------------- 16011 16012 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 16013 Attr_Id : constant Attribute_Id := 16014 Get_Attribute_Id (Attribute_Name (Def)); 16015 T : constant Entity_Id := Entity (Prefix (Def)); 16016 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 16017 F : Entity_Id; 16018 Num_F : Nat; 16019 OK : Boolean; 16020 16021 begin 16022 if No (T) or else T = Any_Id then 16023 return; 16024 end if; 16025 16026 Num_F := 0; 16027 F := First_Formal (Nam); 16028 while Present (F) loop 16029 Num_F := Num_F + 1; 16030 Next_Formal (F); 16031 end loop; 16032 16033 case Attr_Id is 16034 when Attribute_Adjacent 16035 | Attribute_Ceiling 16036 | Attribute_Copy_Sign 16037 | Attribute_Floor 16038 | Attribute_Fraction 16039 | Attribute_Machine 16040 | Attribute_Model 16041 | Attribute_Remainder 16042 | Attribute_Rounding 16043 | Attribute_Unbiased_Rounding 16044 => 16045 OK := Is_Fun 16046 and then Num_F = 1 16047 and then Is_Floating_Point_Type (T); 16048 16049 when Attribute_Image 16050 | Attribute_Pred 16051 | Attribute_Succ 16052 | Attribute_Value 16053 | Attribute_Wide_Image 16054 | Attribute_Wide_Value 16055 => 16056 OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T); 16057 16058 when Attribute_Max 16059 | Attribute_Min 16060 => 16061 OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T); 16062 16063 when Attribute_Input => 16064 OK := (Is_Fun and then Num_F = 1); 16065 16066 when Attribute_Output 16067 | Attribute_Read 16068 | Attribute_Write 16069 => 16070 OK := not Is_Fun and then Num_F = 2; 16071 16072 when others => 16073 OK := False; 16074 end case; 16075 16076 if not OK then 16077 Error_Msg_N 16078 ("attribute reference has wrong profile for subprogram", Def); 16079 end if; 16080 end Valid_Default_Attribute; 16081 16082end Sem_Ch12; 16083