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-2013, 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 Debug; use Debug; 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 Itypes; use Itypes; 38with Lib; use Lib; 39with Lib.Load; use Lib.Load; 40with Lib.Xref; use Lib.Xref; 41with Nlists; use Nlists; 42with Namet; use Namet; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Rident; use Rident; 46with Restrict; use Restrict; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Cat; use Sem_Cat; 51with Sem_Ch3; use Sem_Ch3; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch7; use Sem_Ch7; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Ch10; use Sem_Ch10; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Dim; use Sem_Dim; 58with Sem_Disp; use Sem_Disp; 59with Sem_Elab; use Sem_Elab; 60with Sem_Elim; use Sem_Elim; 61with Sem_Eval; use Sem_Eval; 62with Sem_Prag; use Sem_Prag; 63with Sem_Res; use Sem_Res; 64with Sem_Type; use Sem_Type; 65with Sem_Util; use Sem_Util; 66with Sem_Warn; use Sem_Warn; 67with Stand; use Stand; 68with Sinfo; use Sinfo; 69with Sinfo.CN; use Sinfo.CN; 70with Sinput; use Sinput; 71with Sinput.L; use Sinput.L; 72with Snames; use Snames; 73with Stringt; use Stringt; 74with Uname; use Uname; 75with Table; 76with Tbuild; use Tbuild; 77with Uintp; use Uintp; 78with Urealp; use Urealp; 79 80with GNAT.HTable; 81 82package body Sem_Ch12 is 83 84 ---------------------------------------------------------- 85 -- Implementation of Generic Analysis and Instantiation -- 86 ---------------------------------------------------------- 87 88 -- GNAT implements generics by macro expansion. No attempt is made to share 89 -- generic instantiations (for now). Analysis of a generic definition does 90 -- not perform any expansion action, but the expander must be called on the 91 -- tree for each instantiation, because the expansion may of course depend 92 -- on the generic actuals. All of this is best achieved as follows: 93 -- 94 -- a) Semantic analysis of a generic unit is performed on a copy of the 95 -- tree for the generic unit. All tree modifications that follow analysis 96 -- do not affect the original tree. Links are kept between the original 97 -- tree and the copy, in order to recognize non-local references within 98 -- the generic, and propagate them to each instance (recall that name 99 -- resolution is done on the generic declaration: generics are not really 100 -- macros!). This is summarized in the following diagram: 101 102 -- .-----------. .----------. 103 -- | semantic |<--------------| generic | 104 -- | copy | | unit | 105 -- | |==============>| | 106 -- |___________| global |__________| 107 -- references | | | 108 -- | | | 109 -- .-----|--|. 110 -- | .-----|---. 111 -- | | .----------. 112 -- | | | generic | 113 -- |__| | | 114 -- |__| instance | 115 -- |__________| 116 117 -- b) Each instantiation copies the original tree, and inserts into it a 118 -- series of declarations that describe the mapping between generic formals 119 -- and actuals. For example, a generic In OUT parameter is an object 120 -- renaming of the corresponding actual, etc. Generic IN parameters are 121 -- constant declarations. 122 123 -- c) In order to give the right visibility for these renamings, we use 124 -- a different scheme for package and subprogram instantiations. For 125 -- packages, the list of renamings is inserted into the package 126 -- specification, before the visible declarations of the package. The 127 -- renamings are analyzed before any of the text of the instance, and are 128 -- thus visible at the right place. Furthermore, outside of the instance, 129 -- the generic parameters are visible and denote their corresponding 130 -- actuals. 131 132 -- For subprograms, we create a container package to hold the renamings 133 -- and the subprogram instance itself. Analysis of the package makes the 134 -- renaming declarations visible to the subprogram. After analyzing the 135 -- package, the defining entity for the subprogram is touched-up so that 136 -- it appears declared in the current scope, and not inside the container 137 -- package. 138 139 -- If the instantiation is a compilation unit, the container package is 140 -- given the same name as the subprogram instance. This ensures that 141 -- the elaboration procedure called by the binder, using the compilation 142 -- unit name, calls in fact the elaboration procedure for the package. 143 144 -- Not surprisingly, private types complicate this approach. By saving in 145 -- the original generic object the non-local references, we guarantee that 146 -- the proper entities are referenced at the point of instantiation. 147 -- However, for private types, this by itself does not insure that the 148 -- proper VIEW of the entity is used (the full type may be visible at the 149 -- point of generic definition, but not at instantiation, or vice-versa). 150 -- In order to reference the proper view, we special-case any reference 151 -- to private types in the generic object, by saving both views, one in 152 -- the generic and one in the semantic copy. At time of instantiation, we 153 -- check whether the two views are consistent, and exchange declarations if 154 -- necessary, in order to restore the correct visibility. Similarly, if 155 -- the instance view is private when the generic view was not, we perform 156 -- the exchange. After completing the instantiation, we restore the 157 -- current visibility. The flag Has_Private_View marks identifiers in the 158 -- the generic unit that require checking. 159 160 -- Visibility within nested generic units requires special handling. 161 -- Consider the following scheme: 162 163 -- type Global is ... -- outside of generic unit. 164 -- generic ... 165 -- package Outer is 166 -- ... 167 -- type Semi_Global is ... -- global to inner. 168 169 -- generic ... -- 1 170 -- procedure inner (X1 : Global; X2 : Semi_Global); 171 172 -- procedure in2 is new inner (...); -- 4 173 -- end Outer; 174 175 -- package New_Outer is new Outer (...); -- 2 176 -- procedure New_Inner is new New_Outer.Inner (...); -- 3 177 178 -- The semantic analysis of Outer captures all occurrences of Global. 179 -- The semantic analysis of Inner (at 1) captures both occurrences of 180 -- Global and Semi_Global. 181 182 -- At point 2 (instantiation of Outer), we also produce a generic copy 183 -- of Inner, even though Inner is, at that point, not being instantiated. 184 -- (This is just part of the semantic analysis of New_Outer). 185 186 -- Critically, references to Global within Inner must be preserved, while 187 -- references to Semi_Global should not preserved, because they must now 188 -- resolve to an entity within New_Outer. To distinguish between these, we 189 -- use a global variable, Current_Instantiated_Parent, which is set when 190 -- performing a generic copy during instantiation (at 2). This variable is 191 -- used when performing a generic copy that is not an instantiation, but 192 -- that is nested within one, as the occurrence of 1 within 2. The analysis 193 -- of a nested generic only preserves references that are global to the 194 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to 195 -- determine whether a reference is external to the given parent. 196 197 -- The instantiation at point 3 requires no special treatment. The method 198 -- works as well for further nestings of generic units, but of course the 199 -- variable Current_Instantiated_Parent must be stacked because nested 200 -- instantiations can occur, e.g. the occurrence of 4 within 2. 201 202 -- The instantiation of package and subprogram bodies is handled in a 203 -- similar manner, except that it is delayed until after semantic 204 -- analysis is complete. In this fashion complex cross-dependencies 205 -- between several package declarations and bodies containing generics 206 -- can be compiled which otherwise would diagnose spurious circularities. 207 208 -- For example, it is possible to compile two packages A and B that 209 -- have the following structure: 210 211 -- package A is package B is 212 -- generic ... generic ... 213 -- package G_A is package G_B is 214 215 -- with B; with A; 216 -- package body A is package body B is 217 -- package N_B is new G_B (..) package N_A is new G_A (..) 218 219 -- The table Pending_Instantiations in package Inline is used to keep 220 -- track of body instantiations that are delayed in this manner. Inline 221 -- handles the actual calls to do the body instantiations. This activity 222 -- is part of Inline, since the processing occurs at the same point, and 223 -- for essentially the same reason, as the handling of inlined routines. 224 225 ---------------------------------------------- 226 -- Detection of Instantiation Circularities -- 227 ---------------------------------------------- 228 229 -- If we have a chain of instantiations that is circular, this is static 230 -- error which must be detected at compile time. The detection of these 231 -- circularities is carried out at the point that we insert a generic 232 -- instance spec or body. If there is a circularity, then the analysis of 233 -- the offending spec or body will eventually result in trying to load the 234 -- same unit again, and we detect this problem as we analyze the package 235 -- instantiation for the second time. 236 237 -- At least in some cases after we have detected the circularity, we get 238 -- into trouble if we try to keep going. The following flag is set if a 239 -- circularity is detected, and used to abandon compilation after the 240 -- messages have been posted. 241 242 Circularity_Detected : Boolean := False; 243 -- This should really be reset on encountering a new main unit, but in 244 -- practice we are not using multiple main units so it is not critical. 245 246 ------------------------------------------------- 247 -- Formal packages and partial parametrization -- 248 ------------------------------------------------- 249 250 -- When compiling a generic, a formal package is a local instantiation. If 251 -- declared with a box, its generic formals are visible in the enclosing 252 -- generic. If declared with a partial list of actuals, those actuals that 253 -- are defaulted (covered by an Others clause, or given an explicit box 254 -- initialization) are also visible in the enclosing generic, while those 255 -- that have a corresponding actual are not. 256 257 -- In our source model of instantiation, the same visibility must be 258 -- present in the spec and body of an instance: the names of the formals 259 -- that are defaulted must be made visible within the instance, and made 260 -- invisible (hidden) after the instantiation is complete, so that they 261 -- are not accessible outside of the instance. 262 263 -- In a generic, a formal package is treated like a special instantiation. 264 -- Our Ada 95 compiler handled formals with and without box in different 265 -- ways. With partial parametrization, we use a single model for both. 266 -- We create a package declaration that consists of the specification of 267 -- the generic package, and a set of declarations that map the actuals 268 -- into local renamings, just as we do for bona fide instantiations. For 269 -- defaulted parameters and formals with a box, we copy directly the 270 -- declarations of the formal into this local package. The result is a 271 -- a package whose visible declarations may include generic formals. This 272 -- package is only used for type checking and visibility analysis, and 273 -- never reaches the back-end, so it can freely violate the placement 274 -- rules for generic formal declarations. 275 276 -- The list of declarations (renamings and copies of formals) is built 277 -- by Analyze_Associations, just as for regular instantiations. 278 279 -- At the point of instantiation, conformance checking must be applied only 280 -- to those parameters that were specified in the formal. We perform this 281 -- checking by creating another internal instantiation, this one including 282 -- only the renamings and the formals (the rest of the package spec is not 283 -- relevant to conformance checking). We can then traverse two lists: the 284 -- list of actuals in the instance that corresponds to the formal package, 285 -- and the list of actuals produced for this bogus instantiation. We apply 286 -- the conformance rules to those actuals that are not defaulted (i.e. 287 -- which still appear as generic formals. 288 289 -- When we compile an instance body we must make the right parameters 290 -- visible again. The predicate Is_Generic_Formal indicates which of the 291 -- formals should have its Is_Hidden flag reset. 292 293 ----------------------- 294 -- Local subprograms -- 295 ----------------------- 296 297 procedure Abandon_Instantiation (N : Node_Id); 298 pragma No_Return (Abandon_Instantiation); 299 -- Posts an error message "instantiation abandoned" at the indicated node 300 -- and then raises the exception Instantiation_Error to do it. 301 302 procedure Analyze_Formal_Array_Type 303 (T : in out Entity_Id; 304 Def : Node_Id); 305 -- A formal array type is treated like an array type declaration, and 306 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is 307 -- in-out, because in the case of an anonymous type the entity is 308 -- actually created in the procedure. 309 310 -- The following procedures treat other kinds of formal parameters 311 312 procedure Analyze_Formal_Derived_Interface_Type 313 (N : Node_Id; 314 T : Entity_Id; 315 Def : Node_Id); 316 317 procedure Analyze_Formal_Derived_Type 318 (N : Node_Id; 319 T : Entity_Id; 320 Def : Node_Id); 321 322 procedure Analyze_Formal_Interface_Type 323 (N : Node_Id; 324 T : Entity_Id; 325 Def : Node_Id); 326 327 -- The following subprograms create abbreviated declarations for formal 328 -- scalar types. We introduce an anonymous base of the proper class for 329 -- each of them, and define the formals as constrained first subtypes of 330 -- their bases. The bounds are expressions that are non-static in the 331 -- generic. 332 333 procedure Analyze_Formal_Decimal_Fixed_Point_Type 334 (T : Entity_Id; Def : Node_Id); 335 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); 336 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); 337 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); 338 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); 339 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 340 (T : Entity_Id; Def : Node_Id); 341 342 procedure Analyze_Formal_Private_Type 343 (N : Node_Id; 344 T : Entity_Id; 345 Def : Node_Id); 346 -- Creates a new private type, which does not require completion 347 348 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); 349 -- Ada 2012: Creates a new incomplete type whose actual does not freeze 350 351 procedure Analyze_Generic_Formal_Part (N : Node_Id); 352 -- Analyze generic formal part 353 354 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); 355 -- Create a new access type with the given designated type 356 357 function Analyze_Associations 358 (I_Node : Node_Id; 359 Formals : List_Id; 360 F_Copy : List_Id) return List_Id; 361 -- At instantiation time, build the list of associations between formals 362 -- and actuals. Each association becomes a renaming declaration for the 363 -- formal entity. F_Copy is the analyzed list of formals in the generic 364 -- copy. It is used to apply legality checks to the actuals. I_Node is the 365 -- instantiation node itself. 366 367 procedure Analyze_Subprogram_Instantiation 368 (N : Node_Id; 369 K : Entity_Kind); 370 371 procedure Build_Instance_Compilation_Unit_Nodes 372 (N : Node_Id; 373 Act_Body : Node_Id; 374 Act_Decl : Node_Id); 375 -- This procedure is used in the case where the generic instance of a 376 -- subprogram body or package body is a library unit. In this case, the 377 -- original library unit node for the generic instantiation must be 378 -- replaced by the resulting generic body, and a link made to a new 379 -- compilation unit node for the generic declaration. The argument N is 380 -- the original generic instantiation. Act_Body and Act_Decl are the body 381 -- and declaration of the instance (either package body and declaration 382 -- nodes or subprogram body and declaration nodes depending on the case). 383 -- On return, the node N has been rewritten with the actual body. 384 385 procedure Check_Access_Definition (N : Node_Id); 386 -- Subsidiary routine to null exclusion processing. Perform an assertion 387 -- check on Ada version and the presence of an access definition in N. 388 389 procedure Check_Formal_Packages (P_Id : Entity_Id); 390 -- Apply the following to all formal packages in generic associations 391 392 procedure Check_Formal_Package_Instance 393 (Formal_Pack : Entity_Id; 394 Actual_Pack : Entity_Id); 395 -- Verify that the actuals of the actual instance match the actuals of 396 -- the template for a formal package that is not declared with a box. 397 398 procedure Check_Forward_Instantiation (Decl : Node_Id); 399 -- If the generic is a local entity and the corresponding body has not 400 -- been seen yet, flag enclosing packages to indicate that it will be 401 -- elaborated after the generic body. Subprograms declared in the same 402 -- package cannot be inlined by the front-end because front-end inlining 403 -- requires a strict linear order of elaboration. 404 405 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; 406 -- Check if some association between formals and actuals requires to make 407 -- visible primitives of a tagged type, and make those primitives visible. 408 -- Return the list of primitives whose visibility is modified (to restore 409 -- their visibility later through Restore_Hidden_Primitives). If no 410 -- candidate is found then return No_Elist. 411 412 procedure Check_Hidden_Child_Unit 413 (N : Node_Id; 414 Gen_Unit : Entity_Id; 415 Act_Decl_Id : Entity_Id); 416 -- If the generic unit is an implicit child instance within a parent 417 -- instance, we need to make an explicit test that it is not hidden by 418 -- a child instance of the same name and parent. 419 420 procedure Check_Generic_Actuals 421 (Instance : Entity_Id; 422 Is_Formal_Box : Boolean); 423 -- Similar to previous one. Check the actuals in the instantiation, 424 -- whose views can change between the point of instantiation and the point 425 -- of instantiation of the body. In addition, mark the generic renamings 426 -- as generic actuals, so that they are not compatible with other actuals. 427 -- Recurse on an actual that is a formal package whose declaration has 428 -- a box. 429 430 function Contains_Instance_Of 431 (Inner : Entity_Id; 432 Outer : Entity_Id; 433 N : Node_Id) return Boolean; 434 -- Inner is instantiated within the generic Outer. Check whether Inner 435 -- directly or indirectly contains an instance of Outer or of one of its 436 -- parents, in the case of a subunit. Each generic unit holds a list of 437 -- the entities instantiated within (at any depth). This procedure 438 -- determines whether the set of such lists contains a cycle, i.e. an 439 -- illegal circular instantiation. 440 441 function Denotes_Formal_Package 442 (Pack : Entity_Id; 443 On_Exit : Boolean := False; 444 Instance : Entity_Id := Empty) return Boolean; 445 -- Returns True if E is a formal package of an enclosing generic, or 446 -- the actual for such a formal in an enclosing instantiation. If such 447 -- a package is used as a formal in an nested generic, or as an actual 448 -- in a nested instantiation, the visibility of ITS formals should not 449 -- be modified. When called from within Restore_Private_Views, the flag 450 -- On_Exit is true, to indicate that the search for a possible enclosing 451 -- instance should ignore the current one. In that case Instance denotes 452 -- the declaration for which this is an actual. This declaration may be 453 -- an instantiation in the source, or the internal instantiation that 454 -- corresponds to the actual for a formal package. 455 456 function Earlier (N1, N2 : Node_Id) return Boolean; 457 -- Yields True if N1 and N2 appear in the same compilation unit, 458 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right 459 -- traversal of the tree for the unit. Used to determine the placement 460 -- of freeze nodes for instance bodies that may depend on other instances. 461 462 function Find_Actual_Type 463 (Typ : Entity_Id; 464 Gen_Type : Entity_Id) return Entity_Id; 465 -- When validating the actual types of a child instance, check whether 466 -- the formal is a formal type of the parent unit, and retrieve the current 467 -- actual for it. Typ is the entity in the analyzed formal type declaration 468 -- (component or index type of an array type, or designated type of an 469 -- access formal) and Gen_Type is the enclosing analyzed formal array 470 -- or access type. The desired actual may be a formal of a parent, or may 471 -- be declared in a formal package of a parent. In both cases it is a 472 -- generic actual type because it appears within a visible instance. 473 -- Finally, it may be declared in a parent unit without being a formal 474 -- of that unit, in which case it must be retrieved by visibility. 475 -- Ambiguities may still arise if two homonyms are declared in two formal 476 -- packages, and the prefix of the formal type may be needed to resolve 477 -- the ambiguity in the instance ??? 478 479 function In_Same_Declarative_Part 480 (F_Node : Node_Id; 481 Inst : Node_Id) return Boolean; 482 -- True if the instantiation Inst and the given freeze_node F_Node appear 483 -- within the same declarative part, ignoring subunits, but with no inter- 484 -- vening subprograms or concurrent units. Used to find the proper plave 485 -- for the freeze node of an instance, when the generic is declared in a 486 -- previous instance. If predicate is true, the freeze node of the instance 487 -- can be placed after the freeze node of the previous instance, Otherwise 488 -- it has to be placed at the end of the current declarative part. 489 490 function In_Main_Context (E : Entity_Id) return Boolean; 491 -- Check whether an instantiation is in the context of the main unit. 492 -- Used to determine whether its body should be elaborated to allow 493 -- front-end inlining. 494 495 procedure Set_Instance_Env 496 (Gen_Unit : Entity_Id; 497 Act_Unit : Entity_Id); 498 -- Save current instance on saved environment, to be used to determine 499 -- the global status of entities in nested instances. Part of Save_Env. 500 -- called after verifying that the generic unit is legal for the instance, 501 -- The procedure also examines whether the generic unit is a predefined 502 -- unit, in order to set configuration switches accordingly. As a result 503 -- the procedure must be called after analyzing and freezing the actuals. 504 505 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 506 -- Associate analyzed generic parameter with corresponding 507 -- instance. Used for semantic checks at instantiation time. 508 509 function Has_Been_Exchanged (E : Entity_Id) return Boolean; 510 -- Traverse the Exchanged_Views list to see if a type was private 511 -- and has already been flipped during this phase of instantiation. 512 513 procedure Hide_Current_Scope; 514 -- When instantiating a generic child unit, the parent context must be 515 -- present, but the instance and all entities that may be generated 516 -- must be inserted in the current scope. We leave the current scope 517 -- on the stack, but make its entities invisible to avoid visibility 518 -- problems. This is reversed at the end of the instantiation. This is 519 -- not done for the instantiation of the bodies, which only require the 520 -- instances of the generic parents to be in scope. 521 522 procedure Install_Body 523 (Act_Body : Node_Id; 524 N : Node_Id; 525 Gen_Body : Node_Id; 526 Gen_Decl : Node_Id); 527 -- If the instantiation happens textually before the body of the generic, 528 -- the instantiation of the body must be analyzed after the generic body, 529 -- and not at the point of instantiation. Such early instantiations can 530 -- happen if the generic and the instance appear in a package declaration 531 -- because the generic body can only appear in the corresponding package 532 -- body. Early instantiations can also appear if generic, instance and 533 -- body are all in the declarative part of a subprogram or entry. Entities 534 -- of packages that are early instantiations are delayed, and their freeze 535 -- node appears after the generic body. 536 537 procedure Insert_Freeze_Node_For_Instance 538 (N : Node_Id; 539 F_Node : Node_Id); 540 -- N denotes a package or a subprogram instantiation and F_Node is the 541 -- associated freeze node. Insert the freeze node before the first source 542 -- body which follows immediately after N. If no such body is found, the 543 -- freeze node is inserted at the end of the declarative region which 544 -- contains N. 545 546 procedure Freeze_Subprogram_Body 547 (Inst_Node : Node_Id; 548 Gen_Body : Node_Id; 549 Pack_Id : Entity_Id); 550 -- The generic body may appear textually after the instance, including 551 -- in the proper body of a stub, or within a different package instance. 552 -- Given that the instance can only be elaborated after the generic, we 553 -- place freeze_nodes for the instance and/or for packages that may enclose 554 -- the instance and the generic, so that the back-end can establish the 555 -- proper order of elaboration. 556 557 procedure Init_Env; 558 -- Establish environment for subsequent instantiation. Separated from 559 -- Save_Env because data-structures for visibility handling must be 560 -- initialized before call to Check_Generic_Child_Unit. 561 562 procedure Install_Formal_Packages (Par : Entity_Id); 563 -- Install the visible part of any formal of the parent that is a formal 564 -- package. Note that for the case of a formal package with a box, this 565 -- includes the formal part of the formal package (12.7(10/2)). 566 567 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 568 -- When compiling an instance of a child unit the parent (which is 569 -- itself an instance) is an enclosing scope that must be made 570 -- immediately visible. This procedure is also used to install the non- 571 -- generic parent of a generic child unit when compiling its body, so 572 -- that full views of types in the parent are made visible. 573 574 procedure Remove_Parent (In_Body : Boolean := False); 575 -- Reverse effect after instantiation of child is complete 576 577 procedure Install_Hidden_Primitives 578 (Prims_List : in out Elist_Id; 579 Gen_T : Entity_Id; 580 Act_T : Entity_Id); 581 -- Remove suffix 'P' from hidden primitives of Act_T to match the 582 -- visibility of primitives of Gen_T. The list of primitives to which 583 -- the suffix is removed is added to Prims_List to restore them later. 584 585 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 586 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 587 -- set to No_Elist. 588 589 procedure Inline_Instance_Body 590 (N : Node_Id; 591 Gen_Unit : Entity_Id; 592 Act_Decl : Node_Id); 593 -- If front-end inlining is requested, instantiate the package body, 594 -- and preserve the visibility of its compilation unit, to insure 595 -- that successive instantiations succeed. 596 597 -- The functions Instantiate_XXX perform various legality checks and build 598 -- the declarations for instantiated generic parameters. In all of these 599 -- Formal is the entity in the generic unit, Actual is the entity of 600 -- expression in the generic associations, and Analyzed_Formal is the 601 -- formal in the generic copy, which contains the semantic information to 602 -- be used to validate the actual. 603 604 function Instantiate_Object 605 (Formal : Node_Id; 606 Actual : Node_Id; 607 Analyzed_Formal : Node_Id) return List_Id; 608 609 function Instantiate_Type 610 (Formal : Node_Id; 611 Actual : Node_Id; 612 Analyzed_Formal : Node_Id; 613 Actual_Decls : List_Id) return List_Id; 614 615 function Instantiate_Formal_Subprogram 616 (Formal : Node_Id; 617 Actual : Node_Id; 618 Analyzed_Formal : Node_Id) return Node_Id; 619 620 function Instantiate_Formal_Package 621 (Formal : Node_Id; 622 Actual : Node_Id; 623 Analyzed_Formal : Node_Id) return List_Id; 624 -- If the formal package is declared with a box, special visibility rules 625 -- apply to its formals: they are in the visible part of the package. This 626 -- is true in the declarative region of the formal package, that is to say 627 -- in the enclosing generic or instantiation. For an instantiation, the 628 -- parameters of the formal package are made visible in an explicit step. 629 -- Furthermore, if the actual has a visible USE clause, these formals must 630 -- be made potentially use-visible as well. On exit from the enclosing 631 -- instantiation, the reverse must be done. 632 633 -- For a formal package declared without a box, there are conformance rules 634 -- that apply to the actuals in the generic declaration and the actuals of 635 -- the actual package in the enclosing instantiation. The simplest way to 636 -- apply these rules is to repeat the instantiation of the formal package 637 -- in the context of the enclosing instance, and compare the generic 638 -- associations of this instantiation with those of the actual package. 639 -- This internal instantiation only needs to contain the renamings of the 640 -- formals: the visible and private declarations themselves need not be 641 -- created. 642 643 -- In Ada 2005, the formal package may be only partially parameterized. 644 -- In that case the visibility step must make visible those actuals whose 645 -- corresponding formals were given with a box. A final complication 646 -- involves inherited operations from formal derived types, which must 647 -- be visible if the type is. 648 649 function Is_In_Main_Unit (N : Node_Id) return Boolean; 650 -- Test if given node is in the main unit 651 652 procedure Load_Parent_Of_Generic 653 (N : Node_Id; 654 Spec : Node_Id; 655 Body_Optional : Boolean := False); 656 -- If the generic appears in a separate non-generic library unit, load the 657 -- corresponding body to retrieve the body of the generic. N is the node 658 -- for the generic instantiation, Spec is the generic package declaration. 659 -- 660 -- Body_Optional is a flag that indicates that the body is being loaded to 661 -- ensure that temporaries are generated consistently when there are other 662 -- instances in the current declarative part that precede the one being 663 -- loaded. In that case a missing body is acceptable. 664 665 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); 666 -- Add the context clause of the unit containing a generic unit to a 667 -- compilation unit that is, or contains, an instantiation. 668 669 function Get_Associated_Node (N : Node_Id) return Node_Id; 670 -- In order to propagate semantic information back from the analyzed copy 671 -- to the original generic, we maintain links between selected nodes in the 672 -- generic and their corresponding copies. At the end of generic analysis, 673 -- the routine Save_Global_References traverses the generic tree, examines 674 -- the semantic information, and preserves the links to those nodes that 675 -- contain global information. At instantiation, the information from the 676 -- associated node is placed on the new copy, so that name resolution is 677 -- not repeated. 678 -- 679 -- Three kinds of source nodes have associated nodes: 680 -- 681 -- a) those that can reference (denote) entities, that is identifiers, 682 -- character literals, expanded_names, operator symbols, operators, 683 -- and attribute reference nodes. These nodes have an Entity field 684 -- and are the set of nodes that are in N_Has_Entity. 685 -- 686 -- b) aggregates (N_Aggregate and N_Extension_Aggregate) 687 -- 688 -- c) selected components (N_Selected_Component) 689 -- 690 -- For the first class, the associated node preserves the entity if it is 691 -- global. If the generic contains nested instantiations, the associated 692 -- node itself has been recopied, and a chain of them must be followed. 693 -- 694 -- For aggregates, the associated node allows retrieval of the type, which 695 -- may otherwise not appear in the generic. The view of this type may be 696 -- different between generic and instantiation, and the full view can be 697 -- installed before the instantiation is analyzed. For aggregates of type 698 -- extensions, the same view exchange may have to be performed for some of 699 -- the ancestor types, if their view is private at the point of 700 -- instantiation. 701 -- 702 -- Nodes that are selected components in the parse tree may be rewritten 703 -- as expanded names after resolution, and must be treated as potential 704 -- entity holders, which is why they also have an Associated_Node. 705 -- 706 -- Nodes that do not come from source, such as freeze nodes, do not appear 707 -- in the generic tree, and need not have an associated node. 708 -- 709 -- The associated node is stored in the Associated_Node field. Note that 710 -- this field overlaps Entity, which is fine, because the whole point is 711 -- that we don't need or want the normal Entity field in this situation. 712 713 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 714 -- Within the generic part, entities in the formal package are 715 -- visible. To validate subsequent type declarations, indicate 716 -- the correspondence between the entities in the analyzed formal, 717 -- and the entities in the actual package. There are three packages 718 -- involved in the instantiation of a formal package: the parent 719 -- generic P1 which appears in the generic declaration, the fake 720 -- instantiation P2 which appears in the analyzed generic, and whose 721 -- visible entities may be used in subsequent formals, and the actual 722 -- P3 in the instance. To validate subsequent formals, me indicate 723 -- that the entities in P2 are mapped into those of P3. The mapping of 724 -- entities has to be done recursively for nested packages. 725 726 procedure Move_Freeze_Nodes 727 (Out_Of : Entity_Id; 728 After : Node_Id; 729 L : List_Id); 730 -- Freeze nodes can be generated in the analysis of a generic unit, but 731 -- will not be seen by the back-end. It is necessary to move those nodes 732 -- to the enclosing scope if they freeze an outer entity. We place them 733 -- at the end of the enclosing generic package, which is semantically 734 -- neutral. 735 736 procedure Preanalyze_Actuals (N : Node_Id); 737 -- Analyze actuals to perform name resolution. Full resolution is done 738 -- later, when the expected types are known, but names have to be captured 739 -- before installing parents of generics, that are not visible for the 740 -- actuals themselves. 741 742 function True_Parent (N : Node_Id) return Node_Id; 743 -- For a subunit, return parent of corresponding stub, else return 744 -- parent of node. 745 746 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 747 -- Verify that an attribute that appears as the default for a formal 748 -- subprogram is a function or procedure with the correct profile. 749 750 ------------------------------------------- 751 -- Data Structures for Generic Renamings -- 752 ------------------------------------------- 753 754 -- The map Generic_Renamings associates generic entities with their 755 -- corresponding actuals. Currently used to validate type instances. It 756 -- will eventually be used for all generic parameters to eliminate the 757 -- need for overload resolution in the instance. 758 759 type Assoc_Ptr is new Int; 760 761 Assoc_Null : constant Assoc_Ptr := -1; 762 763 type Assoc is record 764 Gen_Id : Entity_Id; 765 Act_Id : Entity_Id; 766 Next_In_HTable : Assoc_Ptr; 767 end record; 768 769 package Generic_Renamings is new Table.Table 770 (Table_Component_Type => Assoc, 771 Table_Index_Type => Assoc_Ptr, 772 Table_Low_Bound => 0, 773 Table_Initial => 10, 774 Table_Increment => 100, 775 Table_Name => "Generic_Renamings"); 776 777 -- Variable to hold enclosing instantiation. When the environment is 778 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 779 780 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 781 782 -- Hash table for associations 783 784 HTable_Size : constant := 37; 785 type HTable_Range is range 0 .. HTable_Size - 1; 786 787 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 788 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 789 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 790 function Hash (F : Entity_Id) return HTable_Range; 791 792 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 793 Header_Num => HTable_Range, 794 Element => Assoc, 795 Elmt_Ptr => Assoc_Ptr, 796 Null_Ptr => Assoc_Null, 797 Set_Next => Set_Next_Assoc, 798 Next => Next_Assoc, 799 Key => Entity_Id, 800 Get_Key => Get_Gen_Id, 801 Hash => Hash, 802 Equal => "="); 803 804 Exchanged_Views : Elist_Id; 805 -- This list holds the private views that have been exchanged during 806 -- instantiation to restore the visibility of the generic declaration. 807 -- (see comments above). After instantiation, the current visibility is 808 -- reestablished by means of a traversal of this list. 809 810 Hidden_Entities : Elist_Id; 811 -- This list holds the entities of the current scope that are removed 812 -- from immediate visibility when instantiating a child unit. Their 813 -- visibility is restored in Remove_Parent. 814 815 -- Because instantiations can be recursive, the following must be saved 816 -- on entry and restored on exit from an instantiation (spec or body). 817 -- This is done by the two procedures Save_Env and Restore_Env. For 818 -- package and subprogram instantiations (but not for the body instances) 819 -- the action of Save_Env is done in two steps: Init_Env is called before 820 -- Check_Generic_Child_Unit, because setting the parent instances requires 821 -- that the visibility data structures be properly initialized. Once the 822 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 823 824 Parent_Unit_Visible : Boolean := False; 825 -- Parent_Unit_Visible is used when the generic is a child unit, and 826 -- indicates whether the ultimate parent of the generic is visible in the 827 -- instantiation environment. It is used to reset the visibility of the 828 -- parent at the end of the instantiation (see Remove_Parent). 829 830 Instance_Parent_Unit : Entity_Id := Empty; 831 -- This records the ultimate parent unit of an instance of a generic 832 -- child unit and is used in conjunction with Parent_Unit_Visible to 833 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 834 835 type Instance_Env is record 836 Instantiated_Parent : Assoc; 837 Exchanged_Views : Elist_Id; 838 Hidden_Entities : Elist_Id; 839 Current_Sem_Unit : Unit_Number_Type; 840 Parent_Unit_Visible : Boolean := False; 841 Instance_Parent_Unit : Entity_Id := Empty; 842 Switches : Config_Switches_Type; 843 end record; 844 845 package Instance_Envs is new Table.Table ( 846 Table_Component_Type => Instance_Env, 847 Table_Index_Type => Int, 848 Table_Low_Bound => 0, 849 Table_Initial => 32, 850 Table_Increment => 100, 851 Table_Name => "Instance_Envs"); 852 853 procedure Restore_Private_Views 854 (Pack_Id : Entity_Id; 855 Is_Package : Boolean := True); 856 -- Restore the private views of external types, and unmark the generic 857 -- renamings of actuals, so that they become compatible subtypes again. 858 -- For subprograms, Pack_Id is the package constructed to hold the 859 -- renamings. 860 861 procedure Switch_View (T : Entity_Id); 862 -- Switch the partial and full views of a type and its private 863 -- dependents (i.e. its subtypes and derived types). 864 865 ------------------------------------ 866 -- Structures for Error Reporting -- 867 ------------------------------------ 868 869 Instantiation_Node : Node_Id; 870 -- Used by subprograms that validate instantiation of formal parameters 871 -- where there might be no actual on which to place the error message. 872 -- Also used to locate the instantiation node for generic subunits. 873 874 Instantiation_Error : exception; 875 -- When there is a semantic error in the generic parameter matching, 876 -- there is no point in continuing the instantiation, because the 877 -- number of cascaded errors is unpredictable. This exception aborts 878 -- the instantiation process altogether. 879 880 S_Adjustment : Sloc_Adjustment; 881 -- Offset created for each node in an instantiation, in order to keep 882 -- track of the source position of the instantiation in each of its nodes. 883 -- A subsequent semantic error or warning on a construct of the instance 884 -- points to both places: the original generic node, and the point of 885 -- instantiation. See Sinput and Sinput.L for additional details. 886 887 ------------------------------------------------------------ 888 -- Data structure for keeping track when inside a Generic -- 889 ------------------------------------------------------------ 890 891 -- The following table is used to save values of the Inside_A_Generic 892 -- flag (see spec of Sem) when they are saved by Start_Generic. 893 894 package Generic_Flags is new Table.Table ( 895 Table_Component_Type => Boolean, 896 Table_Index_Type => Int, 897 Table_Low_Bound => 0, 898 Table_Initial => 32, 899 Table_Increment => 200, 900 Table_Name => "Generic_Flags"); 901 902 --------------------------- 903 -- Abandon_Instantiation -- 904 --------------------------- 905 906 procedure Abandon_Instantiation (N : Node_Id) is 907 begin 908 Error_Msg_N ("\instantiation abandoned!", N); 909 raise Instantiation_Error; 910 end Abandon_Instantiation; 911 912 -------------------------- 913 -- Analyze_Associations -- 914 -------------------------- 915 916 function Analyze_Associations 917 (I_Node : Node_Id; 918 Formals : List_Id; 919 F_Copy : List_Id) return List_Id 920 is 921 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 922 Assoc : constant List_Id := New_List; 923 Default_Actuals : constant Elist_Id := New_Elmt_List; 924 Gen_Unit : constant Entity_Id := 925 Defining_Entity (Parent (F_Copy)); 926 927 Actuals : List_Id; 928 Actual : Node_Id; 929 Analyzed_Formal : Node_Id; 930 First_Named : Node_Id := Empty; 931 Formal : Node_Id; 932 Match : Node_Id; 933 Named : Node_Id; 934 Saved_Formal : Node_Id; 935 936 Default_Formals : constant List_Id := New_List; 937 -- If an Others_Choice is present, some of the formals may be defaulted. 938 -- To simplify the treatment of visibility in an instance, we introduce 939 -- individual defaults for each such formal. These defaults are 940 -- appended to the list of associations and replace the Others_Choice. 941 942 Found_Assoc : Node_Id; 943 -- Association for the current formal being match. Empty if there are 944 -- no remaining actuals, or if there is no named association with the 945 -- name of the formal. 946 947 Is_Named_Assoc : Boolean; 948 Num_Matched : Int := 0; 949 Num_Actuals : Int := 0; 950 951 Others_Present : Boolean := False; 952 Others_Choice : Node_Id := Empty; 953 -- In Ada 2005, indicates partial parametrization of a formal 954 -- package. As usual an other association must be last in the list. 955 956 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 957 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance 958 -- cannot have a named association for it. AI05-0025 extends this rule 959 -- to formals of formal packages by AI05-0025, and it also applies to 960 -- box-initialized formals. 961 962 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 963 -- Determine whether the parameter types and the return type of Subp 964 -- are fully defined at the point of instantiation. 965 966 function Matching_Actual 967 (F : Entity_Id; 968 A_F : Entity_Id) return Node_Id; 969 -- Find actual that corresponds to a given a formal parameter. If the 970 -- actuals are positional, return the next one, if any. If the actuals 971 -- are named, scan the parameter associations to find the right one. 972 -- A_F is the corresponding entity in the analyzed generic,which is 973 -- placed on the selector name for ASIS use. 974 -- 975 -- In Ada 2005, a named association may be given with a box, in which 976 -- case Matching_Actual sets Found_Assoc to the generic association, 977 -- but return Empty for the actual itself. In this case the code below 978 -- creates a corresponding declaration for the formal. 979 980 function Partial_Parametrization return Boolean; 981 -- Ada 2005: if no match is found for a given formal, check if the 982 -- association for it includes a box, or whether the associations 983 -- include an Others clause. 984 985 procedure Process_Default (F : Entity_Id); 986 -- Add a copy of the declaration of generic formal F to the list of 987 -- associations, and add an explicit box association for F if there 988 -- is none yet, and the default comes from an Others_Choice. 989 990 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 991 -- Determine whether Subp renames one of the subprograms defined in the 992 -- generated package Standard. 993 994 procedure Set_Analyzed_Formal; 995 -- Find the node in the generic copy that corresponds to a given formal. 996 -- The semantic information on this node is used to perform legality 997 -- checks on the actuals. Because semantic analysis can introduce some 998 -- anonymous entities or modify the declaration node itself, the 999 -- correspondence between the two lists is not one-one. In addition to 1000 -- anonymous types, the presence a formal equality will introduce an 1001 -- implicit declaration for the corresponding inequality. 1002 1003 ---------------------------------------- 1004 -- Check_Overloaded_Formal_Subprogram -- 1005 ---------------------------------------- 1006 1007 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1008 Temp_Formal : Entity_Id; 1009 1010 begin 1011 Temp_Formal := First (Formals); 1012 while Present (Temp_Formal) loop 1013 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1014 and then Temp_Formal /= Formal 1015 and then 1016 Chars (Defining_Unit_Name (Specification (Formal))) = 1017 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1018 then 1019 if Present (Found_Assoc) then 1020 Error_Msg_N 1021 ("named association not allowed for overloaded formal", 1022 Found_Assoc); 1023 1024 else 1025 Error_Msg_N 1026 ("named association not allowed for overloaded formal", 1027 Others_Choice); 1028 end if; 1029 1030 Abandon_Instantiation (Instantiation_Node); 1031 end if; 1032 1033 Next (Temp_Formal); 1034 end loop; 1035 end Check_Overloaded_Formal_Subprogram; 1036 1037 ------------------------------- 1038 -- Has_Fully_Defined_Profile -- 1039 ------------------------------- 1040 1041 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1042 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1043 -- Determine whethet type Typ is fully defined 1044 1045 --------------------------- 1046 -- Is_Fully_Defined_Type -- 1047 --------------------------- 1048 1049 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1050 begin 1051 -- A private type without a full view is not fully defined 1052 1053 if Is_Private_Type (Typ) 1054 and then No (Full_View (Typ)) 1055 then 1056 return False; 1057 1058 -- An incomplete type is never fully defined 1059 1060 elsif Is_Incomplete_Type (Typ) then 1061 return False; 1062 1063 -- All other types are fully defined 1064 1065 else 1066 return True; 1067 end if; 1068 end Is_Fully_Defined_Type; 1069 1070 -- Local declarations 1071 1072 Param : Entity_Id; 1073 1074 -- Start of processing for Has_Fully_Defined_Profile 1075 1076 begin 1077 -- Check the parameters 1078 1079 Param := First_Formal (Subp); 1080 while Present (Param) loop 1081 if not Is_Fully_Defined_Type (Etype (Param)) then 1082 return False; 1083 end if; 1084 1085 Next_Formal (Param); 1086 end loop; 1087 1088 -- Check the return type 1089 1090 return Is_Fully_Defined_Type (Etype (Subp)); 1091 end Has_Fully_Defined_Profile; 1092 1093 --------------------- 1094 -- Matching_Actual -- 1095 --------------------- 1096 1097 function Matching_Actual 1098 (F : Entity_Id; 1099 A_F : Entity_Id) return Node_Id 1100 is 1101 Prev : Node_Id; 1102 Act : Node_Id; 1103 1104 begin 1105 Is_Named_Assoc := False; 1106 1107 -- End of list of purely positional parameters 1108 1109 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1110 Found_Assoc := Empty; 1111 Act := Empty; 1112 1113 -- Case of positional parameter corresponding to current formal 1114 1115 elsif No (Selector_Name (Actual)) then 1116 Found_Assoc := Actual; 1117 Act := Explicit_Generic_Actual_Parameter (Actual); 1118 Num_Matched := Num_Matched + 1; 1119 Next (Actual); 1120 1121 -- Otherwise scan list of named actuals to find the one with the 1122 -- desired name. All remaining actuals have explicit names. 1123 1124 else 1125 Is_Named_Assoc := True; 1126 Found_Assoc := Empty; 1127 Act := Empty; 1128 Prev := Empty; 1129 1130 while Present (Actual) loop 1131 if Chars (Selector_Name (Actual)) = Chars (F) then 1132 Set_Entity (Selector_Name (Actual), A_F); 1133 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1134 Generate_Reference (A_F, Selector_Name (Actual)); 1135 Found_Assoc := Actual; 1136 Act := Explicit_Generic_Actual_Parameter (Actual); 1137 Num_Matched := Num_Matched + 1; 1138 exit; 1139 end if; 1140 1141 Prev := Actual; 1142 Next (Actual); 1143 end loop; 1144 1145 -- Reset for subsequent searches. In most cases the named 1146 -- associations are in order. If they are not, we reorder them 1147 -- to avoid scanning twice the same actual. This is not just a 1148 -- question of efficiency: there may be multiple defaults with 1149 -- boxes that have the same name. In a nested instantiation we 1150 -- insert actuals for those defaults, and cannot rely on their 1151 -- names to disambiguate them. 1152 1153 if Actual = First_Named then 1154 Next (First_Named); 1155 1156 elsif Present (Actual) then 1157 Insert_Before (First_Named, Remove_Next (Prev)); 1158 end if; 1159 1160 Actual := First_Named; 1161 end if; 1162 1163 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1164 Set_Used_As_Generic_Actual (Entity (Act)); 1165 end if; 1166 1167 return Act; 1168 end Matching_Actual; 1169 1170 ----------------------------- 1171 -- Partial_Parametrization -- 1172 ----------------------------- 1173 1174 function Partial_Parametrization return Boolean is 1175 begin 1176 return Others_Present 1177 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1178 end Partial_Parametrization; 1179 1180 --------------------- 1181 -- Process_Default -- 1182 --------------------- 1183 1184 procedure Process_Default (F : Entity_Id) is 1185 Loc : constant Source_Ptr := Sloc (I_Node); 1186 F_Id : constant Entity_Id := Defining_Entity (F); 1187 Decl : Node_Id; 1188 Default : Node_Id; 1189 Id : Entity_Id; 1190 1191 begin 1192 -- Append copy of formal declaration to associations, and create new 1193 -- defining identifier for it. 1194 1195 Decl := New_Copy_Tree (F); 1196 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1197 1198 if Nkind (F) in N_Formal_Subprogram_Declaration then 1199 Set_Defining_Unit_Name (Specification (Decl), Id); 1200 1201 else 1202 Set_Defining_Identifier (Decl, Id); 1203 end if; 1204 1205 Append (Decl, Assoc); 1206 1207 if No (Found_Assoc) then 1208 Default := 1209 Make_Generic_Association (Loc, 1210 Selector_Name => New_Occurrence_Of (Id, Loc), 1211 Explicit_Generic_Actual_Parameter => Empty); 1212 Set_Box_Present (Default); 1213 Append (Default, Default_Formals); 1214 end if; 1215 end Process_Default; 1216 1217 --------------------------------- 1218 -- Renames_Standard_Subprogram -- 1219 --------------------------------- 1220 1221 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1222 Id : Entity_Id; 1223 1224 begin 1225 Id := Alias (Subp); 1226 while Present (Id) loop 1227 if Scope (Id) = Standard_Standard then 1228 return True; 1229 end if; 1230 1231 Id := Alias (Id); 1232 end loop; 1233 1234 return False; 1235 end Renames_Standard_Subprogram; 1236 1237 ------------------------- 1238 -- Set_Analyzed_Formal -- 1239 ------------------------- 1240 1241 procedure Set_Analyzed_Formal is 1242 Kind : Node_Kind; 1243 1244 begin 1245 while Present (Analyzed_Formal) loop 1246 Kind := Nkind (Analyzed_Formal); 1247 1248 case Nkind (Formal) is 1249 1250 when N_Formal_Subprogram_Declaration => 1251 exit when Kind in N_Formal_Subprogram_Declaration 1252 and then 1253 Chars 1254 (Defining_Unit_Name (Specification (Formal))) = 1255 Chars 1256 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1257 1258 when N_Formal_Package_Declaration => 1259 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1260 N_Generic_Package_Declaration, 1261 N_Package_Declaration); 1262 1263 when N_Use_Package_Clause | N_Use_Type_Clause => exit; 1264 1265 when others => 1266 1267 -- Skip freeze nodes, and nodes inserted to replace 1268 -- unrecognized pragmas. 1269 1270 exit when 1271 Kind not in N_Formal_Subprogram_Declaration 1272 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1273 N_Freeze_Entity, 1274 N_Null_Statement, 1275 N_Itype_Reference) 1276 and then Chars (Defining_Identifier (Formal)) = 1277 Chars (Defining_Identifier (Analyzed_Formal)); 1278 end case; 1279 1280 Next (Analyzed_Formal); 1281 end loop; 1282 end Set_Analyzed_Formal; 1283 1284 -- Start of processing for Analyze_Associations 1285 1286 begin 1287 Actuals := Generic_Associations (I_Node); 1288 1289 if Present (Actuals) then 1290 1291 -- Check for an Others choice, indicating a partial parametrization 1292 -- for a formal package. 1293 1294 Actual := First (Actuals); 1295 while Present (Actual) loop 1296 if Nkind (Actual) = N_Others_Choice then 1297 Others_Present := True; 1298 Others_Choice := Actual; 1299 1300 if Present (Next (Actual)) then 1301 Error_Msg_N ("others must be last association", Actual); 1302 end if; 1303 1304 -- This subprogram is used both for formal packages and for 1305 -- instantiations. For the latter, associations must all be 1306 -- explicit. 1307 1308 if Nkind (I_Node) /= N_Formal_Package_Declaration 1309 and then Comes_From_Source (I_Node) 1310 then 1311 Error_Msg_N 1312 ("others association not allowed in an instance", 1313 Actual); 1314 end if; 1315 1316 -- In any case, nothing to do after the others association 1317 1318 exit; 1319 1320 elsif Box_Present (Actual) 1321 and then Comes_From_Source (I_Node) 1322 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1323 then 1324 Error_Msg_N 1325 ("box association not allowed in an instance", Actual); 1326 end if; 1327 1328 Next (Actual); 1329 end loop; 1330 1331 -- If named associations are present, save first named association 1332 -- (it may of course be Empty) to facilitate subsequent name search. 1333 1334 First_Named := First (Actuals); 1335 while Present (First_Named) 1336 and then Nkind (First_Named) /= N_Others_Choice 1337 and then No (Selector_Name (First_Named)) 1338 loop 1339 Num_Actuals := Num_Actuals + 1; 1340 Next (First_Named); 1341 end loop; 1342 end if; 1343 1344 Named := First_Named; 1345 while Present (Named) loop 1346 if Nkind (Named) /= N_Others_Choice 1347 and then No (Selector_Name (Named)) 1348 then 1349 Error_Msg_N ("invalid positional actual after named one", Named); 1350 Abandon_Instantiation (Named); 1351 end if; 1352 1353 -- A named association may lack an actual parameter, if it was 1354 -- introduced for a default subprogram that turns out to be local 1355 -- to the outer instantiation. 1356 1357 if Nkind (Named) /= N_Others_Choice 1358 and then Present (Explicit_Generic_Actual_Parameter (Named)) 1359 then 1360 Num_Actuals := Num_Actuals + 1; 1361 end if; 1362 1363 Next (Named); 1364 end loop; 1365 1366 if Present (Formals) then 1367 Formal := First_Non_Pragma (Formals); 1368 Analyzed_Formal := First_Non_Pragma (F_Copy); 1369 1370 if Present (Actuals) then 1371 Actual := First (Actuals); 1372 1373 -- All formals should have default values 1374 1375 else 1376 Actual := Empty; 1377 end if; 1378 1379 while Present (Formal) loop 1380 Set_Analyzed_Formal; 1381 Saved_Formal := Next_Non_Pragma (Formal); 1382 1383 case Nkind (Formal) is 1384 when N_Formal_Object_Declaration => 1385 Match := 1386 Matching_Actual ( 1387 Defining_Identifier (Formal), 1388 Defining_Identifier (Analyzed_Formal)); 1389 1390 if No (Match) and then Partial_Parametrization then 1391 Process_Default (Formal); 1392 else 1393 Append_List 1394 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1395 Assoc); 1396 end if; 1397 1398 when N_Formal_Type_Declaration => 1399 Match := 1400 Matching_Actual ( 1401 Defining_Identifier (Formal), 1402 Defining_Identifier (Analyzed_Formal)); 1403 1404 if No (Match) then 1405 if Partial_Parametrization then 1406 Process_Default (Formal); 1407 1408 else 1409 Error_Msg_Sloc := Sloc (Gen_Unit); 1410 Error_Msg_NE 1411 ("missing actual&", 1412 Instantiation_Node, 1413 Defining_Identifier (Formal)); 1414 Error_Msg_NE ("\in instantiation of & declared#", 1415 Instantiation_Node, Gen_Unit); 1416 Abandon_Instantiation (Instantiation_Node); 1417 end if; 1418 1419 else 1420 Analyze (Match); 1421 Append_List 1422 (Instantiate_Type 1423 (Formal, Match, Analyzed_Formal, Assoc), 1424 Assoc); 1425 1426 -- An instantiation is a freeze point for the actuals, 1427 -- unless this is a rewritten formal package, or the 1428 -- formal is an Ada 2012 formal incomplete type. 1429 1430 if Nkind (I_Node) = N_Formal_Package_Declaration 1431 or else 1432 (Ada_Version >= Ada_2012 1433 and then 1434 Ekind (Defining_Identifier (Analyzed_Formal)) = 1435 E_Incomplete_Type) 1436 then 1437 null; 1438 1439 else 1440 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1441 end if; 1442 end if; 1443 1444 -- A remote access-to-class-wide type is not a legal actual 1445 -- for a generic formal of an access type (E.2.2(17/2)). 1446 -- In GNAT an exception to this rule is introduced when 1447 -- the formal is marked as remote using implementation 1448 -- defined aspect/pragma Remote_Access_Type. In that case 1449 -- the actual must be remote as well. 1450 1451 -- If the current instantiation is the construction of a 1452 -- local copy for a formal package the actuals may be 1453 -- defaulted, and there is no matching actual to check. 1454 1455 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1456 and then 1457 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1458 N_Access_To_Object_Definition 1459 and then Present (Match) 1460 then 1461 declare 1462 Formal_Ent : constant Entity_Id := 1463 Defining_Identifier (Analyzed_Formal); 1464 begin 1465 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1466 = Is_Remote_Types (Formal_Ent) 1467 then 1468 -- Remoteness of formal and actual match 1469 1470 null; 1471 1472 elsif Is_Remote_Types (Formal_Ent) then 1473 1474 -- Remote formal, non-remote actual 1475 1476 Error_Msg_NE 1477 ("actual for& must be remote", Match, Formal_Ent); 1478 1479 else 1480 -- Non-remote formal, remote actual 1481 1482 Error_Msg_NE 1483 ("actual for& may not be remote", 1484 Match, Formal_Ent); 1485 end if; 1486 end; 1487 end if; 1488 1489 when N_Formal_Subprogram_Declaration => 1490 Match := 1491 Matching_Actual 1492 (Defining_Unit_Name (Specification (Formal)), 1493 Defining_Unit_Name (Specification (Analyzed_Formal))); 1494 1495 -- If the formal subprogram has the same name as another 1496 -- formal subprogram of the generic, then a named 1497 -- association is illegal (12.3(9)). Exclude named 1498 -- associations that are generated for a nested instance. 1499 1500 if Present (Match) 1501 and then Is_Named_Assoc 1502 and then Comes_From_Source (Found_Assoc) 1503 then 1504 Check_Overloaded_Formal_Subprogram (Formal); 1505 end if; 1506 1507 -- If there is no corresponding actual, this may be case of 1508 -- partial parametrization, or else the formal has a default 1509 -- or a box. 1510 1511 if No (Match) and then Partial_Parametrization then 1512 Process_Default (Formal); 1513 1514 if Nkind (I_Node) = N_Formal_Package_Declaration then 1515 Check_Overloaded_Formal_Subprogram (Formal); 1516 end if; 1517 1518 else 1519 Append_To (Assoc, 1520 Instantiate_Formal_Subprogram 1521 (Formal, Match, Analyzed_Formal)); 1522 1523 -- An instantiation is a freeze point for the actuals, 1524 -- unless this is a rewritten formal package. 1525 1526 if Nkind (I_Node) /= N_Formal_Package_Declaration 1527 and then Nkind (Match) = N_Identifier 1528 and then Is_Subprogram (Entity (Match)) 1529 1530 -- The actual subprogram may rename a routine defined 1531 -- in Standard. Avoid freezing such renamings because 1532 -- subprograms coming from Standard cannot be frozen. 1533 1534 and then 1535 not Renames_Standard_Subprogram (Entity (Match)) 1536 1537 -- If the actual subprogram comes from a different 1538 -- unit, it is already frozen, either by a body in 1539 -- that unit or by the end of the declarative part 1540 -- of the unit. This check avoids the freezing of 1541 -- subprograms defined in Standard which are used 1542 -- as generic actuals. 1543 1544 and then In_Same_Code_Unit (Entity (Match), I_Node) 1545 and then Has_Fully_Defined_Profile (Entity (Match)) 1546 then 1547 -- Mark the subprogram as having a delayed freeze 1548 -- since this may be an out-of-order action. 1549 1550 Set_Has_Delayed_Freeze (Entity (Match)); 1551 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1552 end if; 1553 end if; 1554 1555 -- If this is a nested generic, preserve default for later 1556 -- instantiations. 1557 1558 if No (Match) 1559 and then Box_Present (Formal) 1560 then 1561 Append_Elmt 1562 (Defining_Unit_Name (Specification (Last (Assoc))), 1563 Default_Actuals); 1564 end if; 1565 1566 when N_Formal_Package_Declaration => 1567 Match := 1568 Matching_Actual ( 1569 Defining_Identifier (Formal), 1570 Defining_Identifier (Original_Node (Analyzed_Formal))); 1571 1572 if No (Match) then 1573 if Partial_Parametrization then 1574 Process_Default (Formal); 1575 1576 else 1577 Error_Msg_Sloc := Sloc (Gen_Unit); 1578 Error_Msg_NE 1579 ("missing actual&", 1580 Instantiation_Node, Defining_Identifier (Formal)); 1581 Error_Msg_NE ("\in instantiation of & declared#", 1582 Instantiation_Node, Gen_Unit); 1583 1584 Abandon_Instantiation (Instantiation_Node); 1585 end if; 1586 1587 else 1588 Analyze (Match); 1589 Append_List 1590 (Instantiate_Formal_Package 1591 (Formal, Match, Analyzed_Formal), 1592 Assoc); 1593 end if; 1594 1595 -- For use type and use package appearing in the generic part, 1596 -- we have already copied them, so we can just move them where 1597 -- they belong (we mustn't recopy them since this would mess up 1598 -- the Sloc values). 1599 1600 when N_Use_Package_Clause | 1601 N_Use_Type_Clause => 1602 if Nkind (Original_Node (I_Node)) = 1603 N_Formal_Package_Declaration 1604 then 1605 Append (New_Copy_Tree (Formal), Assoc); 1606 else 1607 Remove (Formal); 1608 Append (Formal, Assoc); 1609 end if; 1610 1611 when others => 1612 raise Program_Error; 1613 1614 end case; 1615 1616 Formal := Saved_Formal; 1617 Next_Non_Pragma (Analyzed_Formal); 1618 end loop; 1619 1620 if Num_Actuals > Num_Matched then 1621 Error_Msg_Sloc := Sloc (Gen_Unit); 1622 1623 if Present (Selector_Name (Actual)) then 1624 Error_Msg_NE 1625 ("unmatched actual&", 1626 Actual, Selector_Name (Actual)); 1627 Error_Msg_NE ("\in instantiation of& declared#", 1628 Actual, Gen_Unit); 1629 else 1630 Error_Msg_NE 1631 ("unmatched actual in instantiation of& declared#", 1632 Actual, Gen_Unit); 1633 end if; 1634 end if; 1635 1636 elsif Present (Actuals) then 1637 Error_Msg_N 1638 ("too many actuals in generic instantiation", Instantiation_Node); 1639 end if; 1640 1641 -- An instantiation freezes all generic actuals. The only exceptions 1642 -- to this are incomplete types and subprograms which are not fully 1643 -- defined at the point of instantiation. 1644 1645 declare 1646 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 1647 begin 1648 while Present (Elmt) loop 1649 Freeze_Before (I_Node, Node (Elmt)); 1650 Next_Elmt (Elmt); 1651 end loop; 1652 end; 1653 1654 -- If there are default subprograms, normalize the tree by adding 1655 -- explicit associations for them. This is required if the instance 1656 -- appears within a generic. 1657 1658 declare 1659 Elmt : Elmt_Id; 1660 Subp : Entity_Id; 1661 New_D : Node_Id; 1662 1663 begin 1664 Elmt := First_Elmt (Default_Actuals); 1665 while Present (Elmt) loop 1666 if No (Actuals) then 1667 Actuals := New_List; 1668 Set_Generic_Associations (I_Node, Actuals); 1669 end if; 1670 1671 Subp := Node (Elmt); 1672 New_D := 1673 Make_Generic_Association (Sloc (Subp), 1674 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)), 1675 Explicit_Generic_Actual_Parameter => 1676 New_Occurrence_Of (Subp, Sloc (Subp))); 1677 Mark_Rewrite_Insertion (New_D); 1678 Append_To (Actuals, New_D); 1679 Next_Elmt (Elmt); 1680 end loop; 1681 end; 1682 1683 -- If this is a formal package, normalize the parameter list by adding 1684 -- explicit box associations for the formals that are covered by an 1685 -- Others_Choice. 1686 1687 if not Is_Empty_List (Default_Formals) then 1688 Append_List (Default_Formals, Formals); 1689 end if; 1690 1691 return Assoc; 1692 end Analyze_Associations; 1693 1694 ------------------------------- 1695 -- Analyze_Formal_Array_Type -- 1696 ------------------------------- 1697 1698 procedure Analyze_Formal_Array_Type 1699 (T : in out Entity_Id; 1700 Def : Node_Id) 1701 is 1702 DSS : Node_Id; 1703 1704 begin 1705 -- Treated like a non-generic array declaration, with additional 1706 -- semantic checks. 1707 1708 Enter_Name (T); 1709 1710 if Nkind (Def) = N_Constrained_Array_Definition then 1711 DSS := First (Discrete_Subtype_Definitions (Def)); 1712 while Present (DSS) loop 1713 if Nkind_In (DSS, N_Subtype_Indication, 1714 N_Range, 1715 N_Attribute_Reference) 1716 then 1717 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 1718 end if; 1719 1720 Next (DSS); 1721 end loop; 1722 end if; 1723 1724 Array_Type_Declaration (T, Def); 1725 Set_Is_Generic_Type (Base_Type (T)); 1726 1727 if Ekind (Component_Type (T)) = E_Incomplete_Type 1728 and then No (Full_View (Component_Type (T))) 1729 then 1730 Error_Msg_N ("premature usage of incomplete type", Def); 1731 1732 -- Check that range constraint is not allowed on the component type 1733 -- of a generic formal array type (AARM 12.5.3(3)) 1734 1735 elsif Is_Internal (Component_Type (T)) 1736 and then Present (Subtype_Indication (Component_Definition (Def))) 1737 and then Nkind (Original_Node 1738 (Subtype_Indication (Component_Definition (Def)))) = 1739 N_Subtype_Indication 1740 then 1741 Error_Msg_N 1742 ("in a formal, a subtype indication can only be " 1743 & "a subtype mark (RM 12.5.3(3))", 1744 Subtype_Indication (Component_Definition (Def))); 1745 end if; 1746 1747 end Analyze_Formal_Array_Type; 1748 1749 --------------------------------------------- 1750 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 1751 --------------------------------------------- 1752 1753 -- As for other generic types, we create a valid type representation with 1754 -- legal but arbitrary attributes, whose values are never considered 1755 -- static. For all scalar types we introduce an anonymous base type, with 1756 -- the same attributes. We choose the corresponding integer type to be 1757 -- Standard_Integer. 1758 -- Here and in other similar routines, the Sloc of the generated internal 1759 -- type must be the same as the sloc of the defining identifier of the 1760 -- formal type declaration, to provide proper source navigation. 1761 1762 procedure Analyze_Formal_Decimal_Fixed_Point_Type 1763 (T : Entity_Id; 1764 Def : Node_Id) 1765 is 1766 Loc : constant Source_Ptr := Sloc (Def); 1767 1768 Base : constant Entity_Id := 1769 New_Internal_Entity 1770 (E_Decimal_Fixed_Point_Type, 1771 Current_Scope, 1772 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1773 1774 Int_Base : constant Entity_Id := Standard_Integer; 1775 Delta_Val : constant Ureal := Ureal_1; 1776 Digs_Val : constant Uint := Uint_6; 1777 1778 begin 1779 Enter_Name (T); 1780 1781 Set_Etype (Base, Base); 1782 Set_Size_Info (Base, Int_Base); 1783 Set_RM_Size (Base, RM_Size (Int_Base)); 1784 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 1785 Set_Digits_Value (Base, Digs_Val); 1786 Set_Delta_Value (Base, Delta_Val); 1787 Set_Small_Value (Base, Delta_Val); 1788 Set_Scalar_Range (Base, 1789 Make_Range (Loc, 1790 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 1791 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 1792 1793 Set_Is_Generic_Type (Base); 1794 Set_Parent (Base, Parent (Def)); 1795 1796 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 1797 Set_Etype (T, Base); 1798 Set_Size_Info (T, Int_Base); 1799 Set_RM_Size (T, RM_Size (Int_Base)); 1800 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 1801 Set_Digits_Value (T, Digs_Val); 1802 Set_Delta_Value (T, Delta_Val); 1803 Set_Small_Value (T, Delta_Val); 1804 Set_Scalar_Range (T, Scalar_Range (Base)); 1805 Set_Is_Constrained (T); 1806 1807 Check_Restriction (No_Fixed_Point, Def); 1808 end Analyze_Formal_Decimal_Fixed_Point_Type; 1809 1810 ------------------------------------------- 1811 -- Analyze_Formal_Derived_Interface_Type -- 1812 ------------------------------------------- 1813 1814 procedure Analyze_Formal_Derived_Interface_Type 1815 (N : Node_Id; 1816 T : Entity_Id; 1817 Def : Node_Id) 1818 is 1819 Loc : constant Source_Ptr := Sloc (Def); 1820 1821 begin 1822 -- Rewrite as a type declaration of a derived type. This ensures that 1823 -- the interface list and primitive operations are properly captured. 1824 1825 Rewrite (N, 1826 Make_Full_Type_Declaration (Loc, 1827 Defining_Identifier => T, 1828 Type_Definition => Def)); 1829 Analyze (N); 1830 Set_Is_Generic_Type (T); 1831 end Analyze_Formal_Derived_Interface_Type; 1832 1833 --------------------------------- 1834 -- Analyze_Formal_Derived_Type -- 1835 --------------------------------- 1836 1837 procedure Analyze_Formal_Derived_Type 1838 (N : Node_Id; 1839 T : Entity_Id; 1840 Def : Node_Id) 1841 is 1842 Loc : constant Source_Ptr := Sloc (Def); 1843 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 1844 New_N : Node_Id; 1845 1846 begin 1847 Set_Is_Generic_Type (T); 1848 1849 if Private_Present (Def) then 1850 New_N := 1851 Make_Private_Extension_Declaration (Loc, 1852 Defining_Identifier => T, 1853 Discriminant_Specifications => Discriminant_Specifications (N), 1854 Unknown_Discriminants_Present => Unk_Disc, 1855 Subtype_Indication => Subtype_Mark (Def), 1856 Interface_List => Interface_List (Def)); 1857 1858 Set_Abstract_Present (New_N, Abstract_Present (Def)); 1859 Set_Limited_Present (New_N, Limited_Present (Def)); 1860 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 1861 1862 else 1863 New_N := 1864 Make_Full_Type_Declaration (Loc, 1865 Defining_Identifier => T, 1866 Discriminant_Specifications => 1867 Discriminant_Specifications (Parent (T)), 1868 Type_Definition => 1869 Make_Derived_Type_Definition (Loc, 1870 Subtype_Indication => Subtype_Mark (Def))); 1871 1872 Set_Abstract_Present 1873 (Type_Definition (New_N), Abstract_Present (Def)); 1874 Set_Limited_Present 1875 (Type_Definition (New_N), Limited_Present (Def)); 1876 end if; 1877 1878 Rewrite (N, New_N); 1879 Analyze (N); 1880 1881 if Unk_Disc then 1882 if not Is_Composite_Type (T) then 1883 Error_Msg_N 1884 ("unknown discriminants not allowed for elementary types", N); 1885 else 1886 Set_Has_Unknown_Discriminants (T); 1887 Set_Is_Constrained (T, False); 1888 end if; 1889 end if; 1890 1891 -- If the parent type has a known size, so does the formal, which makes 1892 -- legal representation clauses that involve the formal. 1893 1894 Set_Size_Known_At_Compile_Time 1895 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 1896 end Analyze_Formal_Derived_Type; 1897 1898 ---------------------------------- 1899 -- Analyze_Formal_Discrete_Type -- 1900 ---------------------------------- 1901 1902 -- The operations defined for a discrete types are those of an enumeration 1903 -- type. The size is set to an arbitrary value, for use in analyzing the 1904 -- generic unit. 1905 1906 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 1907 Loc : constant Source_Ptr := Sloc (Def); 1908 Lo : Node_Id; 1909 Hi : Node_Id; 1910 1911 Base : constant Entity_Id := 1912 New_Internal_Entity 1913 (E_Floating_Point_Type, Current_Scope, 1914 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1915 1916 begin 1917 Enter_Name (T); 1918 Set_Ekind (T, E_Enumeration_Subtype); 1919 Set_Etype (T, Base); 1920 Init_Size (T, 8); 1921 Init_Alignment (T); 1922 Set_Is_Generic_Type (T); 1923 Set_Is_Constrained (T); 1924 1925 -- For semantic analysis, the bounds of the type must be set to some 1926 -- non-static value. The simplest is to create attribute nodes for those 1927 -- bounds, that refer to the type itself. These bounds are never 1928 -- analyzed but serve as place-holders. 1929 1930 Lo := 1931 Make_Attribute_Reference (Loc, 1932 Attribute_Name => Name_First, 1933 Prefix => New_Reference_To (T, Loc)); 1934 Set_Etype (Lo, T); 1935 1936 Hi := 1937 Make_Attribute_Reference (Loc, 1938 Attribute_Name => Name_Last, 1939 Prefix => New_Reference_To (T, Loc)); 1940 Set_Etype (Hi, T); 1941 1942 Set_Scalar_Range (T, 1943 Make_Range (Loc, 1944 Low_Bound => Lo, 1945 High_Bound => Hi)); 1946 1947 Set_Ekind (Base, E_Enumeration_Type); 1948 Set_Etype (Base, Base); 1949 Init_Size (Base, 8); 1950 Init_Alignment (Base); 1951 Set_Is_Generic_Type (Base); 1952 Set_Scalar_Range (Base, Scalar_Range (T)); 1953 Set_Parent (Base, Parent (Def)); 1954 end Analyze_Formal_Discrete_Type; 1955 1956 ---------------------------------- 1957 -- Analyze_Formal_Floating_Type -- 1958 --------------------------------- 1959 1960 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 1961 Base : constant Entity_Id := 1962 New_Internal_Entity 1963 (E_Floating_Point_Type, Current_Scope, 1964 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1965 1966 begin 1967 -- The various semantic attributes are taken from the predefined type 1968 -- Float, just so that all of them are initialized. Their values are 1969 -- never used because no constant folding or expansion takes place in 1970 -- the generic itself. 1971 1972 Enter_Name (T); 1973 Set_Ekind (T, E_Floating_Point_Subtype); 1974 Set_Etype (T, Base); 1975 Set_Size_Info (T, (Standard_Float)); 1976 Set_RM_Size (T, RM_Size (Standard_Float)); 1977 Set_Digits_Value (T, Digits_Value (Standard_Float)); 1978 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 1979 Set_Is_Constrained (T); 1980 1981 Set_Is_Generic_Type (Base); 1982 Set_Etype (Base, Base); 1983 Set_Size_Info (Base, (Standard_Float)); 1984 Set_RM_Size (Base, RM_Size (Standard_Float)); 1985 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 1986 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 1987 Set_Parent (Base, Parent (Def)); 1988 1989 Check_Restriction (No_Floating_Point, Def); 1990 end Analyze_Formal_Floating_Type; 1991 1992 ----------------------------------- 1993 -- Analyze_Formal_Interface_Type;-- 1994 ----------------------------------- 1995 1996 procedure Analyze_Formal_Interface_Type 1997 (N : Node_Id; 1998 T : Entity_Id; 1999 Def : Node_Id) 2000 is 2001 Loc : constant Source_Ptr := Sloc (N); 2002 New_N : Node_Id; 2003 2004 begin 2005 New_N := 2006 Make_Full_Type_Declaration (Loc, 2007 Defining_Identifier => T, 2008 Type_Definition => Def); 2009 2010 Rewrite (N, New_N); 2011 Analyze (N); 2012 Set_Is_Generic_Type (T); 2013 end Analyze_Formal_Interface_Type; 2014 2015 --------------------------------- 2016 -- Analyze_Formal_Modular_Type -- 2017 --------------------------------- 2018 2019 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2020 begin 2021 -- Apart from their entity kind, generic modular types are treated like 2022 -- signed integer types, and have the same attributes. 2023 2024 Analyze_Formal_Signed_Integer_Type (T, Def); 2025 Set_Ekind (T, E_Modular_Integer_Subtype); 2026 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2027 2028 end Analyze_Formal_Modular_Type; 2029 2030 --------------------------------------- 2031 -- Analyze_Formal_Object_Declaration -- 2032 --------------------------------------- 2033 2034 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2035 E : constant Node_Id := Default_Expression (N); 2036 Id : constant Node_Id := Defining_Identifier (N); 2037 K : Entity_Kind; 2038 T : Node_Id; 2039 2040 begin 2041 Enter_Name (Id); 2042 2043 -- Determine the mode of the formal object 2044 2045 if Out_Present (N) then 2046 K := E_Generic_In_Out_Parameter; 2047 2048 if not In_Present (N) then 2049 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2050 end if; 2051 2052 else 2053 K := E_Generic_In_Parameter; 2054 end if; 2055 2056 if Present (Subtype_Mark (N)) then 2057 Find_Type (Subtype_Mark (N)); 2058 T := Entity (Subtype_Mark (N)); 2059 2060 -- Verify that there is no redundant null exclusion 2061 2062 if Null_Exclusion_Present (N) then 2063 if not Is_Access_Type (T) then 2064 Error_Msg_N 2065 ("null exclusion can only apply to an access type", N); 2066 2067 elsif Can_Never_Be_Null (T) then 2068 Error_Msg_NE 2069 ("`NOT NULL` not allowed (& already excludes null)", 2070 N, T); 2071 end if; 2072 end if; 2073 2074 -- Ada 2005 (AI-423): Formal object with an access definition 2075 2076 else 2077 Check_Access_Definition (N); 2078 T := Access_Definition 2079 (Related_Nod => N, 2080 N => Access_Definition (N)); 2081 end if; 2082 2083 if Ekind (T) = E_Incomplete_Type then 2084 declare 2085 Error_Node : Node_Id; 2086 2087 begin 2088 if Present (Subtype_Mark (N)) then 2089 Error_Node := Subtype_Mark (N); 2090 else 2091 Check_Access_Definition (N); 2092 Error_Node := Access_Definition (N); 2093 end if; 2094 2095 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2096 end; 2097 end if; 2098 2099 if K = E_Generic_In_Parameter then 2100 2101 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2102 2103 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2104 Error_Msg_N 2105 ("generic formal of mode IN must not be of limited type", N); 2106 Explain_Limited_Type (T, N); 2107 end if; 2108 2109 if Is_Abstract_Type (T) then 2110 Error_Msg_N 2111 ("generic formal of mode IN must not be of abstract type", N); 2112 end if; 2113 2114 if Present (E) then 2115 Preanalyze_Spec_Expression (E, T); 2116 2117 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2118 Error_Msg_N 2119 ("initialization not allowed for limited types", E); 2120 Explain_Limited_Type (T, E); 2121 end if; 2122 end if; 2123 2124 Set_Ekind (Id, K); 2125 Set_Etype (Id, T); 2126 2127 -- Case of generic IN OUT parameter 2128 2129 else 2130 -- If the formal has an unconstrained type, construct its actual 2131 -- subtype, as is done for subprogram formals. In this fashion, all 2132 -- its uses can refer to specific bounds. 2133 2134 Set_Ekind (Id, K); 2135 Set_Etype (Id, T); 2136 2137 if (Is_Array_Type (T) 2138 and then not Is_Constrained (T)) 2139 or else 2140 (Ekind (T) = E_Record_Type 2141 and then Has_Discriminants (T)) 2142 then 2143 declare 2144 Non_Freezing_Ref : constant Node_Id := 2145 New_Reference_To (Id, Sloc (Id)); 2146 Decl : Node_Id; 2147 2148 begin 2149 -- Make sure the actual subtype doesn't generate bogus freezing 2150 2151 Set_Must_Not_Freeze (Non_Freezing_Ref); 2152 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2153 Insert_Before_And_Analyze (N, Decl); 2154 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2155 end; 2156 else 2157 Set_Actual_Subtype (Id, T); 2158 end if; 2159 2160 if Present (E) then 2161 Error_Msg_N 2162 ("initialization not allowed for `IN OUT` formals", N); 2163 end if; 2164 end if; 2165 2166 if Has_Aspects (N) then 2167 Analyze_Aspect_Specifications (N, Id); 2168 end if; 2169 end Analyze_Formal_Object_Declaration; 2170 2171 ---------------------------------------------- 2172 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2173 ---------------------------------------------- 2174 2175 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2176 (T : Entity_Id; 2177 Def : Node_Id) 2178 is 2179 Loc : constant Source_Ptr := Sloc (Def); 2180 Base : constant Entity_Id := 2181 New_Internal_Entity 2182 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2183 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2184 2185 begin 2186 -- The semantic attributes are set for completeness only, their values 2187 -- will never be used, since all properties of the type are non-static. 2188 2189 Enter_Name (T); 2190 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2191 Set_Etype (T, Base); 2192 Set_Size_Info (T, Standard_Integer); 2193 Set_RM_Size (T, RM_Size (Standard_Integer)); 2194 Set_Small_Value (T, Ureal_1); 2195 Set_Delta_Value (T, Ureal_1); 2196 Set_Scalar_Range (T, 2197 Make_Range (Loc, 2198 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2199 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2200 Set_Is_Constrained (T); 2201 2202 Set_Is_Generic_Type (Base); 2203 Set_Etype (Base, Base); 2204 Set_Size_Info (Base, Standard_Integer); 2205 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2206 Set_Small_Value (Base, Ureal_1); 2207 Set_Delta_Value (Base, Ureal_1); 2208 Set_Scalar_Range (Base, Scalar_Range (T)); 2209 Set_Parent (Base, Parent (Def)); 2210 2211 Check_Restriction (No_Fixed_Point, Def); 2212 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2213 2214 ---------------------------------------- 2215 -- Analyze_Formal_Package_Declaration -- 2216 ---------------------------------------- 2217 2218 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2219 Loc : constant Source_Ptr := Sloc (N); 2220 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2221 Formal : Entity_Id; 2222 Gen_Id : constant Node_Id := Name (N); 2223 Gen_Decl : Node_Id; 2224 Gen_Unit : Entity_Id; 2225 New_N : Node_Id; 2226 Parent_Installed : Boolean := False; 2227 Renaming : Node_Id; 2228 Parent_Instance : Entity_Id; 2229 Renaming_In_Par : Entity_Id; 2230 Associations : Boolean := True; 2231 2232 Vis_Prims_List : Elist_Id := No_Elist; 2233 -- List of primitives made temporarily visible in the instantiation 2234 -- to match the visibility of the formal type 2235 2236 function Build_Local_Package return Node_Id; 2237 -- The formal package is rewritten so that its parameters are replaced 2238 -- with corresponding declarations. For parameters with bona fide 2239 -- associations these declarations are created by Analyze_Associations 2240 -- as for a regular instantiation. For boxed parameters, we preserve 2241 -- the formal declarations and analyze them, in order to introduce 2242 -- entities of the right kind in the environment of the formal. 2243 2244 ------------------------- 2245 -- Build_Local_Package -- 2246 ------------------------- 2247 2248 function Build_Local_Package return Node_Id is 2249 Decls : List_Id; 2250 Pack_Decl : Node_Id; 2251 2252 begin 2253 -- Within the formal, the name of the generic package is a renaming 2254 -- of the formal (as for a regular instantiation). 2255 2256 Pack_Decl := 2257 Make_Package_Declaration (Loc, 2258 Specification => 2259 Copy_Generic_Node 2260 (Specification (Original_Node (Gen_Decl)), 2261 Empty, Instantiating => True)); 2262 2263 Renaming := Make_Package_Renaming_Declaration (Loc, 2264 Defining_Unit_Name => 2265 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2266 Name => New_Occurrence_Of (Formal, Loc)); 2267 2268 if Nkind (Gen_Id) = N_Identifier 2269 and then Chars (Gen_Id) = Chars (Pack_Id) 2270 then 2271 Error_Msg_NE 2272 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2273 end if; 2274 2275 -- If the formal is declared with a box, or with an others choice, 2276 -- create corresponding declarations for all entities in the formal 2277 -- part, so that names with the proper types are available in the 2278 -- specification of the formal package. 2279 2280 -- On the other hand, if there are no associations, then all the 2281 -- formals must have defaults, and this will be checked by the 2282 -- call to Analyze_Associations. 2283 2284 if Box_Present (N) 2285 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2286 then 2287 declare 2288 Formal_Decl : Node_Id; 2289 2290 begin 2291 -- TBA : for a formal package, need to recurse ??? 2292 2293 Decls := New_List; 2294 Formal_Decl := 2295 First 2296 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2297 while Present (Formal_Decl) loop 2298 Append_To 2299 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True)); 2300 Next (Formal_Decl); 2301 end loop; 2302 end; 2303 2304 -- If generic associations are present, use Analyze_Associations to 2305 -- create the proper renaming declarations. 2306 2307 else 2308 declare 2309 Act_Tree : constant Node_Id := 2310 Copy_Generic_Node 2311 (Original_Node (Gen_Decl), Empty, 2312 Instantiating => True); 2313 2314 begin 2315 Generic_Renamings.Set_Last (0); 2316 Generic_Renamings_HTable.Reset; 2317 Instantiation_Node := N; 2318 2319 Decls := 2320 Analyze_Associations 2321 (I_Node => Original_Node (N), 2322 Formals => Generic_Formal_Declarations (Act_Tree), 2323 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2324 2325 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2326 end; 2327 end if; 2328 2329 Append (Renaming, To => Decls); 2330 2331 -- Add generated declarations ahead of local declarations in 2332 -- the package. 2333 2334 if No (Visible_Declarations (Specification (Pack_Decl))) then 2335 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2336 else 2337 Insert_List_Before 2338 (First (Visible_Declarations (Specification (Pack_Decl))), 2339 Decls); 2340 end if; 2341 2342 return Pack_Decl; 2343 end Build_Local_Package; 2344 2345 -- Start of processing for Analyze_Formal_Package_Declaration 2346 2347 begin 2348 Text_IO_Kludge (Gen_Id); 2349 2350 Init_Env; 2351 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2352 Gen_Unit := Entity (Gen_Id); 2353 2354 -- Check for a formal package that is a package renaming 2355 2356 if Present (Renamed_Object (Gen_Unit)) then 2357 2358 -- Indicate that unit is used, before replacing it with renamed 2359 -- entity for use below. 2360 2361 if In_Extended_Main_Source_Unit (N) then 2362 Set_Is_Instantiated (Gen_Unit); 2363 Generate_Reference (Gen_Unit, N); 2364 end if; 2365 2366 Gen_Unit := Renamed_Object (Gen_Unit); 2367 end if; 2368 2369 if Ekind (Gen_Unit) /= E_Generic_Package then 2370 Error_Msg_N ("expect generic package name", Gen_Id); 2371 Restore_Env; 2372 goto Leave; 2373 2374 elsif Gen_Unit = Current_Scope then 2375 Error_Msg_N 2376 ("generic package cannot be used as a formal package of itself", 2377 Gen_Id); 2378 Restore_Env; 2379 goto Leave; 2380 2381 elsif In_Open_Scopes (Gen_Unit) then 2382 if Is_Compilation_Unit (Gen_Unit) 2383 and then Is_Child_Unit (Current_Scope) 2384 then 2385 -- Special-case the error when the formal is a parent, and 2386 -- continue analysis to minimize cascaded errors. 2387 2388 Error_Msg_N 2389 ("generic parent cannot be used as formal package " 2390 & "of a child unit", 2391 Gen_Id); 2392 2393 else 2394 Error_Msg_N 2395 ("generic package cannot be used as a formal package " 2396 & "within itself", 2397 Gen_Id); 2398 Restore_Env; 2399 goto Leave; 2400 end if; 2401 end if; 2402 2403 -- Check that name of formal package does not hide name of generic, 2404 -- or its leading prefix. This check must be done separately because 2405 -- the name of the generic has already been analyzed. 2406 2407 declare 2408 Gen_Name : Entity_Id; 2409 2410 begin 2411 Gen_Name := Gen_Id; 2412 while Nkind (Gen_Name) = N_Expanded_Name loop 2413 Gen_Name := Prefix (Gen_Name); 2414 end loop; 2415 2416 if Chars (Gen_Name) = Chars (Pack_Id) then 2417 Error_Msg_NE 2418 ("& is hidden within declaration of formal package", 2419 Gen_Id, Gen_Name); 2420 end if; 2421 end; 2422 2423 if Box_Present (N) 2424 or else No (Generic_Associations (N)) 2425 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2426 then 2427 Associations := False; 2428 end if; 2429 2430 -- If there are no generic associations, the generic parameters appear 2431 -- as local entities and are instantiated like them. We copy the generic 2432 -- package declaration as if it were an instantiation, and analyze it 2433 -- like a regular package, except that we treat the formals as 2434 -- additional visible components. 2435 2436 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2437 2438 if In_Extended_Main_Source_Unit (N) then 2439 Set_Is_Instantiated (Gen_Unit); 2440 Generate_Reference (Gen_Unit, N); 2441 end if; 2442 2443 Formal := New_Copy (Pack_Id); 2444 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 2445 2446 begin 2447 -- Make local generic without formals. The formals will be replaced 2448 -- with internal declarations. 2449 2450 New_N := Build_Local_Package; 2451 2452 -- If there are errors in the parameter list, Analyze_Associations 2453 -- raises Instantiation_Error. Patch the declaration to prevent 2454 -- further exception propagation. 2455 2456 exception 2457 when Instantiation_Error => 2458 2459 Enter_Name (Formal); 2460 Set_Ekind (Formal, E_Variable); 2461 Set_Etype (Formal, Any_Type); 2462 Restore_Hidden_Primitives (Vis_Prims_List); 2463 2464 if Parent_Installed then 2465 Remove_Parent; 2466 end if; 2467 2468 goto Leave; 2469 end; 2470 2471 Rewrite (N, New_N); 2472 Set_Defining_Unit_Name (Specification (New_N), Formal); 2473 Set_Generic_Parent (Specification (N), Gen_Unit); 2474 Set_Instance_Env (Gen_Unit, Formal); 2475 Set_Is_Generic_Instance (Formal); 2476 2477 Enter_Name (Formal); 2478 Set_Ekind (Formal, E_Package); 2479 Set_Etype (Formal, Standard_Void_Type); 2480 Set_Inner_Instances (Formal, New_Elmt_List); 2481 Push_Scope (Formal); 2482 2483 if Is_Child_Unit (Gen_Unit) 2484 and then Parent_Installed 2485 then 2486 -- Similarly, we have to make the name of the formal visible in the 2487 -- parent instance, to resolve properly fully qualified names that 2488 -- may appear in the generic unit. The parent instance has been 2489 -- placed on the scope stack ahead of the current scope. 2490 2491 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2492 2493 Renaming_In_Par := 2494 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2495 Set_Ekind (Renaming_In_Par, E_Package); 2496 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2497 Set_Scope (Renaming_In_Par, Parent_Instance); 2498 Set_Parent (Renaming_In_Par, Parent (Formal)); 2499 Set_Renamed_Object (Renaming_In_Par, Formal); 2500 Append_Entity (Renaming_In_Par, Parent_Instance); 2501 end if; 2502 2503 Analyze (Specification (N)); 2504 2505 -- The formals for which associations are provided are not visible 2506 -- outside of the formal package. The others are still declared by a 2507 -- formal parameter declaration. 2508 2509 -- If there are no associations, the only local entity to hide is the 2510 -- generated package renaming itself. 2511 2512 declare 2513 E : Entity_Id; 2514 2515 begin 2516 E := First_Entity (Formal); 2517 while Present (E) loop 2518 if Associations 2519 and then not Is_Generic_Formal (E) 2520 then 2521 Set_Is_Hidden (E); 2522 end if; 2523 2524 if Ekind (E) = E_Package 2525 and then Renamed_Entity (E) = Formal 2526 then 2527 Set_Is_Hidden (E); 2528 exit; 2529 end if; 2530 2531 Next_Entity (E); 2532 end loop; 2533 end; 2534 2535 End_Package_Scope (Formal); 2536 Restore_Hidden_Primitives (Vis_Prims_List); 2537 2538 if Parent_Installed then 2539 Remove_Parent; 2540 end if; 2541 2542 Restore_Env; 2543 2544 -- Inside the generic unit, the formal package is a regular package, but 2545 -- no body is needed for it. Note that after instantiation, the defining 2546 -- unit name we need is in the new tree and not in the original (see 2547 -- Package_Instantiation). A generic formal package is an instance, and 2548 -- can be used as an actual for an inner instance. 2549 2550 Set_Has_Completion (Formal, True); 2551 2552 -- Add semantic information to the original defining identifier. 2553 -- for ASIS use. 2554 2555 Set_Ekind (Pack_Id, E_Package); 2556 Set_Etype (Pack_Id, Standard_Void_Type); 2557 Set_Scope (Pack_Id, Scope (Formal)); 2558 Set_Has_Completion (Pack_Id, True); 2559 2560 <<Leave>> 2561 if Has_Aspects (N) then 2562 Analyze_Aspect_Specifications (N, Pack_Id); 2563 end if; 2564 end Analyze_Formal_Package_Declaration; 2565 2566 --------------------------------- 2567 -- Analyze_Formal_Private_Type -- 2568 --------------------------------- 2569 2570 procedure Analyze_Formal_Private_Type 2571 (N : Node_Id; 2572 T : Entity_Id; 2573 Def : Node_Id) 2574 is 2575 begin 2576 New_Private_Type (N, T, Def); 2577 2578 -- Set the size to an arbitrary but legal value 2579 2580 Set_Size_Info (T, Standard_Integer); 2581 Set_RM_Size (T, RM_Size (Standard_Integer)); 2582 end Analyze_Formal_Private_Type; 2583 2584 ------------------------------------ 2585 -- Analyze_Formal_Incomplete_Type -- 2586 ------------------------------------ 2587 2588 procedure Analyze_Formal_Incomplete_Type 2589 (T : Entity_Id; 2590 Def : Node_Id) 2591 is 2592 begin 2593 Enter_Name (T); 2594 Set_Ekind (T, E_Incomplete_Type); 2595 Set_Etype (T, T); 2596 Set_Private_Dependents (T, New_Elmt_List); 2597 2598 if Tagged_Present (Def) then 2599 Set_Is_Tagged_Type (T); 2600 Make_Class_Wide_Type (T); 2601 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2602 end if; 2603 end Analyze_Formal_Incomplete_Type; 2604 2605 ---------------------------------------- 2606 -- Analyze_Formal_Signed_Integer_Type -- 2607 ---------------------------------------- 2608 2609 procedure Analyze_Formal_Signed_Integer_Type 2610 (T : Entity_Id; 2611 Def : Node_Id) 2612 is 2613 Base : constant Entity_Id := 2614 New_Internal_Entity 2615 (E_Signed_Integer_Type, 2616 Current_Scope, 2617 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2618 2619 begin 2620 Enter_Name (T); 2621 2622 Set_Ekind (T, E_Signed_Integer_Subtype); 2623 Set_Etype (T, Base); 2624 Set_Size_Info (T, Standard_Integer); 2625 Set_RM_Size (T, RM_Size (Standard_Integer)); 2626 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 2627 Set_Is_Constrained (T); 2628 2629 Set_Is_Generic_Type (Base); 2630 Set_Size_Info (Base, Standard_Integer); 2631 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2632 Set_Etype (Base, Base); 2633 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 2634 Set_Parent (Base, Parent (Def)); 2635 end Analyze_Formal_Signed_Integer_Type; 2636 2637 ------------------------------------------- 2638 -- Analyze_Formal_Subprogram_Declaration -- 2639 ------------------------------------------- 2640 2641 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 2642 Spec : constant Node_Id := Specification (N); 2643 Def : constant Node_Id := Default_Name (N); 2644 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 2645 Subp : Entity_Id; 2646 2647 begin 2648 if Nam = Error then 2649 return; 2650 end if; 2651 2652 if Nkind (Nam) = N_Defining_Program_Unit_Name then 2653 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 2654 goto Leave; 2655 end if; 2656 2657 Analyze_Subprogram_Declaration (N); 2658 Set_Is_Formal_Subprogram (Nam); 2659 Set_Has_Completion (Nam); 2660 2661 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 2662 Set_Is_Abstract_Subprogram (Nam); 2663 Set_Is_Dispatching_Operation (Nam); 2664 2665 declare 2666 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 2667 begin 2668 if No (Ctrl_Type) then 2669 Error_Msg_N 2670 ("abstract formal subprogram must have a controlling type", 2671 N); 2672 2673 elsif Ada_Version >= Ada_2012 2674 and then Is_Incomplete_Type (Ctrl_Type) 2675 then 2676 Error_Msg_NE 2677 ("controlling type of abstract formal subprogram cannot " & 2678 "be incomplete type", N, Ctrl_Type); 2679 2680 else 2681 Check_Controlling_Formals (Ctrl_Type, Nam); 2682 end if; 2683 end; 2684 end if; 2685 2686 -- Default name is resolved at the point of instantiation 2687 2688 if Box_Present (N) then 2689 null; 2690 2691 -- Else default is bound at the point of generic declaration 2692 2693 elsif Present (Def) then 2694 if Nkind (Def) = N_Operator_Symbol then 2695 Find_Direct_Name (Def); 2696 2697 elsif Nkind (Def) /= N_Attribute_Reference then 2698 Analyze (Def); 2699 2700 else 2701 -- For an attribute reference, analyze the prefix and verify 2702 -- that it has the proper profile for the subprogram. 2703 2704 Analyze (Prefix (Def)); 2705 Valid_Default_Attribute (Nam, Def); 2706 goto Leave; 2707 end if; 2708 2709 -- Default name may be overloaded, in which case the interpretation 2710 -- with the correct profile must be selected, as for a renaming. 2711 -- If the definition is an indexed component, it must denote a 2712 -- member of an entry family. If it is a selected component, it 2713 -- can be a protected operation. 2714 2715 if Etype (Def) = Any_Type then 2716 goto Leave; 2717 2718 elsif Nkind (Def) = N_Selected_Component then 2719 if not Is_Overloadable (Entity (Selector_Name (Def))) then 2720 Error_Msg_N ("expect valid subprogram name as default", Def); 2721 end if; 2722 2723 elsif Nkind (Def) = N_Indexed_Component then 2724 if Is_Entity_Name (Prefix (Def)) then 2725 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 2726 Error_Msg_N ("expect valid subprogram name as default", Def); 2727 end if; 2728 2729 elsif Nkind (Prefix (Def)) = N_Selected_Component then 2730 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 2731 E_Entry_Family 2732 then 2733 Error_Msg_N ("expect valid subprogram name as default", Def); 2734 end if; 2735 2736 else 2737 Error_Msg_N ("expect valid subprogram name as default", Def); 2738 goto Leave; 2739 end if; 2740 2741 elsif Nkind (Def) = N_Character_Literal then 2742 2743 -- Needs some type checks: subprogram should be parameterless??? 2744 2745 Resolve (Def, (Etype (Nam))); 2746 2747 elsif not Is_Entity_Name (Def) 2748 or else not Is_Overloadable (Entity (Def)) 2749 then 2750 Error_Msg_N ("expect valid subprogram name as default", Def); 2751 goto Leave; 2752 2753 elsif not Is_Overloaded (Def) then 2754 Subp := Entity (Def); 2755 2756 if Subp = Nam then 2757 Error_Msg_N ("premature usage of formal subprogram", Def); 2758 2759 elsif not Entity_Matches_Spec (Subp, Nam) then 2760 Error_Msg_N ("no visible entity matches specification", Def); 2761 end if; 2762 2763 -- More than one interpretation, so disambiguate as for a renaming 2764 2765 else 2766 declare 2767 I : Interp_Index; 2768 I1 : Interp_Index := 0; 2769 It : Interp; 2770 It1 : Interp; 2771 2772 begin 2773 Subp := Any_Id; 2774 Get_First_Interp (Def, I, It); 2775 while Present (It.Nam) loop 2776 if Entity_Matches_Spec (It.Nam, Nam) then 2777 if Subp /= Any_Id then 2778 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 2779 2780 if It1 = No_Interp then 2781 Error_Msg_N ("ambiguous default subprogram", Def); 2782 else 2783 Subp := It1.Nam; 2784 end if; 2785 2786 exit; 2787 2788 else 2789 I1 := I; 2790 Subp := It.Nam; 2791 end if; 2792 end if; 2793 2794 Get_Next_Interp (I, It); 2795 end loop; 2796 end; 2797 2798 if Subp /= Any_Id then 2799 2800 -- Subprogram found, generate reference to it 2801 2802 Set_Entity (Def, Subp); 2803 Generate_Reference (Subp, Def); 2804 2805 if Subp = Nam then 2806 Error_Msg_N ("premature usage of formal subprogram", Def); 2807 2808 elsif Ekind (Subp) /= E_Operator then 2809 Check_Mode_Conformant (Subp, Nam); 2810 end if; 2811 2812 else 2813 Error_Msg_N ("no visible subprogram matches specification", N); 2814 end if; 2815 end if; 2816 end if; 2817 2818 <<Leave>> 2819 if Has_Aspects (N) then 2820 Analyze_Aspect_Specifications (N, Nam); 2821 end if; 2822 2823 end Analyze_Formal_Subprogram_Declaration; 2824 2825 ------------------------------------- 2826 -- Analyze_Formal_Type_Declaration -- 2827 ------------------------------------- 2828 2829 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 2830 Def : constant Node_Id := Formal_Type_Definition (N); 2831 T : Entity_Id; 2832 2833 begin 2834 T := Defining_Identifier (N); 2835 2836 if Present (Discriminant_Specifications (N)) 2837 and then Nkind (Def) /= N_Formal_Private_Type_Definition 2838 then 2839 Error_Msg_N 2840 ("discriminants not allowed for this formal type", T); 2841 end if; 2842 2843 -- Enter the new name, and branch to specific routine 2844 2845 case Nkind (Def) is 2846 when N_Formal_Private_Type_Definition => 2847 Analyze_Formal_Private_Type (N, T, Def); 2848 2849 when N_Formal_Derived_Type_Definition => 2850 Analyze_Formal_Derived_Type (N, T, Def); 2851 2852 when N_Formal_Incomplete_Type_Definition => 2853 Analyze_Formal_Incomplete_Type (T, Def); 2854 2855 when N_Formal_Discrete_Type_Definition => 2856 Analyze_Formal_Discrete_Type (T, Def); 2857 2858 when N_Formal_Signed_Integer_Type_Definition => 2859 Analyze_Formal_Signed_Integer_Type (T, Def); 2860 2861 when N_Formal_Modular_Type_Definition => 2862 Analyze_Formal_Modular_Type (T, Def); 2863 2864 when N_Formal_Floating_Point_Definition => 2865 Analyze_Formal_Floating_Type (T, Def); 2866 2867 when N_Formal_Ordinary_Fixed_Point_Definition => 2868 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 2869 2870 when N_Formal_Decimal_Fixed_Point_Definition => 2871 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 2872 2873 when N_Array_Type_Definition => 2874 Analyze_Formal_Array_Type (T, Def); 2875 2876 when N_Access_To_Object_Definition | 2877 N_Access_Function_Definition | 2878 N_Access_Procedure_Definition => 2879 Analyze_Generic_Access_Type (T, Def); 2880 2881 -- Ada 2005: a interface declaration is encoded as an abstract 2882 -- record declaration or a abstract type derivation. 2883 2884 when N_Record_Definition => 2885 Analyze_Formal_Interface_Type (N, T, Def); 2886 2887 when N_Derived_Type_Definition => 2888 Analyze_Formal_Derived_Interface_Type (N, T, Def); 2889 2890 when N_Error => 2891 null; 2892 2893 when others => 2894 raise Program_Error; 2895 2896 end case; 2897 2898 Set_Is_Generic_Type (T); 2899 2900 if Has_Aspects (N) then 2901 Analyze_Aspect_Specifications (N, T); 2902 end if; 2903 end Analyze_Formal_Type_Declaration; 2904 2905 ------------------------------------ 2906 -- Analyze_Function_Instantiation -- 2907 ------------------------------------ 2908 2909 procedure Analyze_Function_Instantiation (N : Node_Id) is 2910 begin 2911 Analyze_Subprogram_Instantiation (N, E_Function); 2912 end Analyze_Function_Instantiation; 2913 2914 --------------------------------- 2915 -- Analyze_Generic_Access_Type -- 2916 --------------------------------- 2917 2918 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 2919 begin 2920 Enter_Name (T); 2921 2922 if Nkind (Def) = N_Access_To_Object_Definition then 2923 Access_Type_Declaration (T, Def); 2924 2925 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 2926 and then No (Full_View (Designated_Type (T))) 2927 and then not Is_Generic_Type (Designated_Type (T)) 2928 then 2929 Error_Msg_N ("premature usage of incomplete type", Def); 2930 2931 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 2932 Error_Msg_N 2933 ("only a subtype mark is allowed in a formal", Def); 2934 end if; 2935 2936 else 2937 Access_Subprogram_Declaration (T, Def); 2938 end if; 2939 end Analyze_Generic_Access_Type; 2940 2941 --------------------------------- 2942 -- Analyze_Generic_Formal_Part -- 2943 --------------------------------- 2944 2945 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 2946 Gen_Parm_Decl : Node_Id; 2947 2948 begin 2949 -- The generic formals are processed in the scope of the generic unit, 2950 -- where they are immediately visible. The scope is installed by the 2951 -- caller. 2952 2953 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 2954 2955 while Present (Gen_Parm_Decl) loop 2956 Analyze (Gen_Parm_Decl); 2957 Next (Gen_Parm_Decl); 2958 end loop; 2959 2960 Generate_Reference_To_Generic_Formals (Current_Scope); 2961 end Analyze_Generic_Formal_Part; 2962 2963 ------------------------------------------ 2964 -- Analyze_Generic_Package_Declaration -- 2965 ------------------------------------------ 2966 2967 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 2968 Loc : constant Source_Ptr := Sloc (N); 2969 Id : Entity_Id; 2970 New_N : Node_Id; 2971 Save_Parent : Node_Id; 2972 Renaming : Node_Id; 2973 Decls : constant List_Id := 2974 Visible_Declarations (Specification (N)); 2975 Decl : Node_Id; 2976 2977 begin 2978 Check_SPARK_Restriction ("generic is not allowed", N); 2979 2980 -- We introduce a renaming of the enclosing package, to have a usable 2981 -- entity as the prefix of an expanded name for a local entity of the 2982 -- form Par.P.Q, where P is the generic package. This is because a local 2983 -- entity named P may hide it, so that the usual visibility rules in 2984 -- the instance will not resolve properly. 2985 2986 Renaming := 2987 Make_Package_Renaming_Declaration (Loc, 2988 Defining_Unit_Name => 2989 Make_Defining_Identifier (Loc, 2990 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 2991 Name => Make_Identifier (Loc, Chars (Defining_Entity (N)))); 2992 2993 if Present (Decls) then 2994 Decl := First (Decls); 2995 while Present (Decl) 2996 and then Nkind (Decl) = N_Pragma 2997 loop 2998 Next (Decl); 2999 end loop; 3000 3001 if Present (Decl) then 3002 Insert_Before (Decl, Renaming); 3003 else 3004 Append (Renaming, Visible_Declarations (Specification (N))); 3005 end if; 3006 3007 else 3008 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3009 end if; 3010 3011 -- Create copy of generic unit, and save for instantiation. If the unit 3012 -- is a child unit, do not copy the specifications for the parent, which 3013 -- are not part of the generic tree. 3014 3015 Save_Parent := Parent_Spec (N); 3016 Set_Parent_Spec (N, Empty); 3017 3018 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3019 Set_Parent_Spec (New_N, Save_Parent); 3020 Rewrite (N, New_N); 3021 Id := Defining_Entity (N); 3022 Generate_Definition (Id); 3023 3024 -- Expansion is not applied to generic units 3025 3026 Start_Generic; 3027 3028 Enter_Name (Id); 3029 Set_Ekind (Id, E_Generic_Package); 3030 Set_Etype (Id, Standard_Void_Type); 3031 Push_Scope (Id); 3032 Enter_Generic_Scope (Id); 3033 Set_Inner_Instances (Id, New_Elmt_List); 3034 3035 Set_Categorization_From_Pragmas (N); 3036 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3037 3038 -- Link the declaration of the generic homonym in the generic copy to 3039 -- the package it renames, so that it is always resolved properly. 3040 3041 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3042 Set_Entity (Associated_Node (Name (Renaming)), Id); 3043 3044 -- For a library unit, we have reconstructed the entity for the unit, 3045 -- and must reset it in the library tables. 3046 3047 if Nkind (Parent (N)) = N_Compilation_Unit then 3048 Set_Cunit_Entity (Current_Sem_Unit, Id); 3049 end if; 3050 3051 Analyze_Generic_Formal_Part (N); 3052 3053 -- After processing the generic formals, analysis proceeds as for a 3054 -- non-generic package. 3055 3056 Analyze (Specification (N)); 3057 3058 Validate_Categorization_Dependency (N, Id); 3059 3060 End_Generic; 3061 3062 End_Package_Scope (Id); 3063 Exit_Generic_Scope (Id); 3064 3065 if Nkind (Parent (N)) /= N_Compilation_Unit then 3066 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3067 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3068 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3069 3070 else 3071 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3072 Validate_RT_RAT_Component (N); 3073 3074 -- If this is a spec without a body, check that generic parameters 3075 -- are referenced. 3076 3077 if not Body_Required (Parent (N)) then 3078 Check_References (Id); 3079 end if; 3080 end if; 3081 3082 if Has_Aspects (N) then 3083 Analyze_Aspect_Specifications (N, Id); 3084 end if; 3085 end Analyze_Generic_Package_Declaration; 3086 3087 -------------------------------------------- 3088 -- Analyze_Generic_Subprogram_Declaration -- 3089 -------------------------------------------- 3090 3091 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3092 Spec : Node_Id; 3093 Id : Entity_Id; 3094 Formals : List_Id; 3095 New_N : Node_Id; 3096 Result_Type : Entity_Id; 3097 Save_Parent : Node_Id; 3098 Typ : Entity_Id; 3099 3100 begin 3101 Check_SPARK_Restriction ("generic is not allowed", N); 3102 3103 -- Create copy of generic unit, and save for instantiation. If the unit 3104 -- is a child unit, do not copy the specifications for the parent, which 3105 -- are not part of the generic tree. 3106 3107 Save_Parent := Parent_Spec (N); 3108 Set_Parent_Spec (N, Empty); 3109 3110 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3111 Set_Parent_Spec (New_N, Save_Parent); 3112 Rewrite (N, New_N); 3113 3114 -- The aspect specifications are not attached to the tree, and must 3115 -- be copied and attached to the generic copy explicitly. 3116 3117 if Present (Aspect_Specifications (New_N)) then 3118 declare 3119 Aspects : constant List_Id := Aspect_Specifications (N); 3120 begin 3121 Set_Has_Aspects (N, False); 3122 Move_Aspects (New_N, N); 3123 Set_Has_Aspects (Original_Node (N), False); 3124 Set_Aspect_Specifications (Original_Node (N), Aspects); 3125 end; 3126 end if; 3127 3128 Spec := Specification (N); 3129 Id := Defining_Entity (Spec); 3130 Generate_Definition (Id); 3131 Set_Contract (Id, Make_Contract (Sloc (Id))); 3132 3133 if Nkind (Id) = N_Defining_Operator_Symbol then 3134 Error_Msg_N 3135 ("operator symbol not allowed for generic subprogram", Id); 3136 end if; 3137 3138 Start_Generic; 3139 3140 Enter_Name (Id); 3141 3142 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3143 Push_Scope (Id); 3144 Enter_Generic_Scope (Id); 3145 Set_Inner_Instances (Id, New_Elmt_List); 3146 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3147 3148 Analyze_Generic_Formal_Part (N); 3149 3150 Formals := Parameter_Specifications (Spec); 3151 3152 if Present (Formals) then 3153 Process_Formals (Formals, Spec); 3154 end if; 3155 3156 if Nkind (Spec) = N_Function_Specification then 3157 Set_Ekind (Id, E_Generic_Function); 3158 3159 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3160 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3161 Set_Etype (Id, Result_Type); 3162 3163 -- Check restriction imposed by AI05-073: a generic function 3164 -- cannot return an abstract type or an access to such. 3165 3166 -- This is a binding interpretation should it apply to earlier 3167 -- versions of Ada as well as Ada 2012??? 3168 3169 if Is_Abstract_Type (Designated_Type (Result_Type)) 3170 and then Ada_Version >= Ada_2012 3171 then 3172 Error_Msg_N ("generic function cannot have an access result" 3173 & " that designates an abstract type", Spec); 3174 end if; 3175 3176 else 3177 Find_Type (Result_Definition (Spec)); 3178 Typ := Entity (Result_Definition (Spec)); 3179 3180 if Is_Abstract_Type (Typ) 3181 and then Ada_Version >= Ada_2012 3182 then 3183 Error_Msg_N 3184 ("generic function cannot have abstract result type", Spec); 3185 end if; 3186 3187 -- If a null exclusion is imposed on the result type, then create 3188 -- a null-excluding itype (an access subtype) and use it as the 3189 -- function's Etype. 3190 3191 if Is_Access_Type (Typ) 3192 and then Null_Exclusion_Present (Spec) 3193 then 3194 Set_Etype (Id, 3195 Create_Null_Excluding_Itype 3196 (T => Typ, 3197 Related_Nod => Spec, 3198 Scope_Id => Defining_Unit_Name (Spec))); 3199 else 3200 Set_Etype (Id, Typ); 3201 end if; 3202 end if; 3203 3204 else 3205 Set_Ekind (Id, E_Generic_Procedure); 3206 Set_Etype (Id, Standard_Void_Type); 3207 end if; 3208 3209 -- For a library unit, we have reconstructed the entity for the unit, 3210 -- and must reset it in the library tables. We also make sure that 3211 -- Body_Required is set properly in the original compilation unit node. 3212 3213 if Nkind (Parent (N)) = N_Compilation_Unit then 3214 Set_Cunit_Entity (Current_Sem_Unit, Id); 3215 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3216 end if; 3217 3218 Set_Categorization_From_Pragmas (N); 3219 Validate_Categorization_Dependency (N, Id); 3220 3221 Save_Global_References (Original_Node (N)); 3222 3223 -- For ASIS purposes, convert any postcondition, precondition pragmas 3224 -- into aspects, if N is not a compilation unit by itself, in order to 3225 -- enable the analysis of expressions inside the corresponding PPC 3226 -- pragmas. 3227 3228 if ASIS_Mode and then Is_List_Member (N) then 3229 Make_Aspect_For_PPC_In_Gen_Sub_Decl (N); 3230 end if; 3231 3232 -- To capture global references, analyze the expressions of aspects, 3233 -- and propagate information to original tree. Note that in this case 3234 -- analysis of attributes is not delayed until the freeze point. 3235 3236 -- It seems very hard to recreate the proper visibility of the generic 3237 -- subprogram at a later point because the analysis of an aspect may 3238 -- create pragmas after the generic copies have been made ??? 3239 3240 if Has_Aspects (N) then 3241 declare 3242 Aspect : Node_Id; 3243 3244 begin 3245 Aspect := First (Aspect_Specifications (N)); 3246 while Present (Aspect) loop 3247 if Get_Aspect_Id (Chars (Identifier (Aspect))) 3248 /= Aspect_Warnings 3249 then 3250 Analyze (Expression (Aspect)); 3251 end if; 3252 Next (Aspect); 3253 end loop; 3254 3255 Aspect := First (Aspect_Specifications (Original_Node (N))); 3256 while Present (Aspect) loop 3257 Save_Global_References (Expression (Aspect)); 3258 Next (Aspect); 3259 end loop; 3260 end; 3261 end if; 3262 3263 End_Generic; 3264 End_Scope; 3265 Exit_Generic_Scope (Id); 3266 Generate_Reference_To_Formals (Id); 3267 3268 List_Inherited_Pre_Post_Aspects (Id); 3269 end Analyze_Generic_Subprogram_Declaration; 3270 3271 ----------------------------------- 3272 -- Analyze_Package_Instantiation -- 3273 ----------------------------------- 3274 3275 procedure Analyze_Package_Instantiation (N : Node_Id) is 3276 Loc : constant Source_Ptr := Sloc (N); 3277 Gen_Id : constant Node_Id := Name (N); 3278 3279 Act_Decl : Node_Id; 3280 Act_Decl_Name : Node_Id; 3281 Act_Decl_Id : Entity_Id; 3282 Act_Spec : Node_Id; 3283 Act_Tree : Node_Id; 3284 3285 Gen_Decl : Node_Id; 3286 Gen_Unit : Entity_Id; 3287 3288 Is_Actual_Pack : constant Boolean := 3289 Is_Internal (Defining_Entity (N)); 3290 3291 Env_Installed : Boolean := False; 3292 Parent_Installed : Boolean := False; 3293 Renaming_List : List_Id; 3294 Unit_Renaming : Node_Id; 3295 Needs_Body : Boolean; 3296 Inline_Now : Boolean := False; 3297 3298 Save_Style_Check : constant Boolean := Style_Check; 3299 -- Save style check mode for restore on exit 3300 3301 procedure Delay_Descriptors (E : Entity_Id); 3302 -- Delay generation of subprogram descriptors for given entity 3303 3304 function Might_Inline_Subp return Boolean; 3305 -- If inlining is active and the generic contains inlined subprograms, 3306 -- we instantiate the body. This may cause superfluous instantiations, 3307 -- but it is simpler than detecting the need for the body at the point 3308 -- of inlining, when the context of the instance is not available. 3309 3310 function Must_Inline_Subp return Boolean; 3311 -- If inlining is active and the generic contains inlined subprograms, 3312 -- return True if some of the inlined subprograms must be inlined by 3313 -- the frontend. 3314 3315 ----------------------- 3316 -- Delay_Descriptors -- 3317 ----------------------- 3318 3319 procedure Delay_Descriptors (E : Entity_Id) is 3320 begin 3321 if not Delay_Subprogram_Descriptors (E) then 3322 Set_Delay_Subprogram_Descriptors (E); 3323 Pending_Descriptor.Append (E); 3324 end if; 3325 end Delay_Descriptors; 3326 3327 ----------------------- 3328 -- Might_Inline_Subp -- 3329 ----------------------- 3330 3331 function Might_Inline_Subp return Boolean is 3332 E : Entity_Id; 3333 3334 begin 3335 if not Inline_Processing_Required then 3336 return False; 3337 3338 else 3339 E := First_Entity (Gen_Unit); 3340 while Present (E) loop 3341 if Is_Subprogram (E) 3342 and then Is_Inlined (E) 3343 then 3344 return True; 3345 end if; 3346 3347 Next_Entity (E); 3348 end loop; 3349 end if; 3350 3351 return False; 3352 end Might_Inline_Subp; 3353 3354 ---------------------- 3355 -- Must_Inline_Subp -- 3356 ---------------------- 3357 3358 function Must_Inline_Subp return Boolean is 3359 E : Entity_Id; 3360 3361 begin 3362 if not Inline_Processing_Required then 3363 return False; 3364 3365 else 3366 E := First_Entity (Gen_Unit); 3367 while Present (E) loop 3368 if Is_Subprogram (E) 3369 and then Is_Inlined (E) 3370 and then Must_Inline (E) 3371 then 3372 return True; 3373 end if; 3374 3375 Next_Entity (E); 3376 end loop; 3377 end if; 3378 3379 return False; 3380 end Must_Inline_Subp; 3381 3382 -- Local declarations 3383 3384 Vis_Prims_List : Elist_Id := No_Elist; 3385 -- List of primitives made temporarily visible in the instantiation 3386 -- to match the visibility of the formal type 3387 3388 -- Start of processing for Analyze_Package_Instantiation 3389 3390 begin 3391 Check_SPARK_Restriction ("generic is not allowed", N); 3392 3393 -- Very first thing: apply the special kludge for Text_IO processing 3394 -- in case we are instantiating one of the children of [Wide_]Text_IO. 3395 3396 Text_IO_Kludge (Name (N)); 3397 3398 -- Make node global for error reporting 3399 3400 Instantiation_Node := N; 3401 3402 -- Turn off style checking in instances. If the check is enabled on the 3403 -- generic unit, a warning in an instance would just be noise. If not 3404 -- enabled on the generic, then a warning in an instance is just wrong. 3405 3406 Style_Check := False; 3407 3408 -- Case of instantiation of a generic package 3409 3410 if Nkind (N) = N_Package_Instantiation then 3411 Act_Decl_Id := New_Copy (Defining_Entity (N)); 3412 Set_Comes_From_Source (Act_Decl_Id, True); 3413 3414 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 3415 Act_Decl_Name := 3416 Make_Defining_Program_Unit_Name (Loc, 3417 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))), 3418 Defining_Identifier => Act_Decl_Id); 3419 else 3420 Act_Decl_Name := Act_Decl_Id; 3421 end if; 3422 3423 -- Case of instantiation of a formal package 3424 3425 else 3426 Act_Decl_Id := Defining_Identifier (N); 3427 Act_Decl_Name := Act_Decl_Id; 3428 end if; 3429 3430 Generate_Definition (Act_Decl_Id); 3431 Preanalyze_Actuals (N); 3432 3433 Init_Env; 3434 Env_Installed := True; 3435 3436 -- Reset renaming map for formal types. The mapping is established 3437 -- when analyzing the generic associations, but some mappings are 3438 -- inherited from formal packages of parent units, and these are 3439 -- constructed when the parents are installed. 3440 3441 Generic_Renamings.Set_Last (0); 3442 Generic_Renamings_HTable.Reset; 3443 3444 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 3445 Gen_Unit := Entity (Gen_Id); 3446 3447 -- Verify that it is the name of a generic package 3448 3449 -- A visibility glitch: if the instance is a child unit and the generic 3450 -- is the generic unit of a parent instance (i.e. both the parent and 3451 -- the child units are instances of the same package) the name now 3452 -- denotes the renaming within the parent, not the intended generic 3453 -- unit. See if there is a homonym that is the desired generic. The 3454 -- renaming declaration must be visible inside the instance of the 3455 -- child, but not when analyzing the name in the instantiation itself. 3456 3457 if Ekind (Gen_Unit) = E_Package 3458 and then Present (Renamed_Entity (Gen_Unit)) 3459 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 3460 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 3461 and then Present (Homonym (Gen_Unit)) 3462 then 3463 Gen_Unit := Homonym (Gen_Unit); 3464 end if; 3465 3466 if Etype (Gen_Unit) = Any_Type then 3467 Restore_Env; 3468 goto Leave; 3469 3470 elsif Ekind (Gen_Unit) /= E_Generic_Package then 3471 3472 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 3473 3474 if From_With_Type (Gen_Unit) then 3475 Error_Msg_N 3476 ("cannot instantiate a limited withed package", Gen_Id); 3477 else 3478 Error_Msg_N 3479 ("expect name of generic package in instantiation", Gen_Id); 3480 end if; 3481 3482 Restore_Env; 3483 goto Leave; 3484 end if; 3485 3486 if In_Extended_Main_Source_Unit (N) then 3487 Set_Is_Instantiated (Gen_Unit); 3488 Generate_Reference (Gen_Unit, N); 3489 3490 if Present (Renamed_Object (Gen_Unit)) then 3491 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 3492 Generate_Reference (Renamed_Object (Gen_Unit), N); 3493 end if; 3494 end if; 3495 3496 if Nkind (Gen_Id) = N_Identifier 3497 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 3498 then 3499 Error_Msg_NE 3500 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 3501 3502 elsif Nkind (Gen_Id) = N_Expanded_Name 3503 and then Is_Child_Unit (Gen_Unit) 3504 and then Nkind (Prefix (Gen_Id)) = N_Identifier 3505 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 3506 then 3507 Error_Msg_N 3508 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 3509 end if; 3510 3511 Set_Entity (Gen_Id, Gen_Unit); 3512 3513 -- If generic is a renaming, get original generic unit 3514 3515 if Present (Renamed_Object (Gen_Unit)) 3516 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 3517 then 3518 Gen_Unit := Renamed_Object (Gen_Unit); 3519 end if; 3520 3521 -- Verify that there are no circular instantiations 3522 3523 if In_Open_Scopes (Gen_Unit) then 3524 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 3525 Restore_Env; 3526 goto Leave; 3527 3528 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 3529 Error_Msg_Node_2 := Current_Scope; 3530 Error_Msg_NE 3531 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 3532 Circularity_Detected := True; 3533 Restore_Env; 3534 goto Leave; 3535 3536 else 3537 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 3538 3539 -- Initialize renamings map, for error checking, and the list that 3540 -- holds private entities whose views have changed between generic 3541 -- definition and instantiation. If this is the instance created to 3542 -- validate an actual package, the instantiation environment is that 3543 -- of the enclosing instance. 3544 3545 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 3546 3547 -- Copy original generic tree, to produce text for instantiation 3548 3549 Act_Tree := 3550 Copy_Generic_Node 3551 (Original_Node (Gen_Decl), Empty, Instantiating => True); 3552 3553 Act_Spec := Specification (Act_Tree); 3554 3555 -- If this is the instance created to validate an actual package, 3556 -- only the formals matter, do not examine the package spec itself. 3557 3558 if Is_Actual_Pack then 3559 Set_Visible_Declarations (Act_Spec, New_List); 3560 Set_Private_Declarations (Act_Spec, New_List); 3561 end if; 3562 3563 Renaming_List := 3564 Analyze_Associations 3565 (I_Node => N, 3566 Formals => Generic_Formal_Declarations (Act_Tree), 3567 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 3568 3569 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 3570 3571 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 3572 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 3573 Set_Is_Generic_Instance (Act_Decl_Id); 3574 3575 Set_Generic_Parent (Act_Spec, Gen_Unit); 3576 3577 -- References to the generic in its own declaration or its body are 3578 -- references to the instance. Add a renaming declaration for the 3579 -- generic unit itself. This declaration, as well as the renaming 3580 -- declarations for the generic formals, must remain private to the 3581 -- unit: the formals, because this is the language semantics, and 3582 -- the unit because its use is an artifact of the implementation. 3583 3584 Unit_Renaming := 3585 Make_Package_Renaming_Declaration (Loc, 3586 Defining_Unit_Name => 3587 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 3588 Name => New_Reference_To (Act_Decl_Id, Loc)); 3589 3590 Append (Unit_Renaming, Renaming_List); 3591 3592 -- The renaming declarations are the first local declarations of 3593 -- the new unit. 3594 3595 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 3596 Insert_List_Before 3597 (First (Visible_Declarations (Act_Spec)), Renaming_List); 3598 else 3599 Set_Visible_Declarations (Act_Spec, Renaming_List); 3600 end if; 3601 3602 Act_Decl := 3603 Make_Package_Declaration (Loc, 3604 Specification => Act_Spec); 3605 3606 -- Save the instantiation node, for subsequent instantiation of the 3607 -- body, if there is one and we are generating code for the current 3608 -- unit. Mark the unit as having a body, to avoid a premature error 3609 -- message. 3610 3611 -- We instantiate the body if we are generating code, if we are 3612 -- generating cross-reference information, or if we are building 3613 -- trees for ASIS use. 3614 3615 declare 3616 Enclosing_Body_Present : Boolean := False; 3617 -- If the generic unit is not a compilation unit, then a body may 3618 -- be present in its parent even if none is required. We create a 3619 -- tentative pending instantiation for the body, which will be 3620 -- discarded if none is actually present. 3621 3622 Scop : Entity_Id; 3623 3624 begin 3625 if Scope (Gen_Unit) /= Standard_Standard 3626 and then not Is_Child_Unit (Gen_Unit) 3627 then 3628 Scop := Scope (Gen_Unit); 3629 3630 while Present (Scop) 3631 and then Scop /= Standard_Standard 3632 loop 3633 if Unit_Requires_Body (Scop) then 3634 Enclosing_Body_Present := True; 3635 exit; 3636 3637 elsif In_Open_Scopes (Scop) 3638 and then In_Package_Body (Scop) 3639 then 3640 Enclosing_Body_Present := True; 3641 exit; 3642 end if; 3643 3644 exit when Is_Compilation_Unit (Scop); 3645 Scop := Scope (Scop); 3646 end loop; 3647 end if; 3648 3649 -- If front-end inlining is enabled, and this is a unit for which 3650 -- code will be generated, we instantiate the body at once. 3651 3652 -- This is done if the instance is not the main unit, and if the 3653 -- generic is not a child unit of another generic, to avoid scope 3654 -- problems and the reinstallation of parent instances. 3655 3656 if Expander_Active 3657 and then (not Is_Child_Unit (Gen_Unit) 3658 or else not Is_Generic_Unit (Scope (Gen_Unit))) 3659 and then Might_Inline_Subp 3660 and then not Is_Actual_Pack 3661 then 3662 if not Debug_Flag_Dot_K 3663 and then Front_End_Inlining 3664 and then (Is_In_Main_Unit (N) 3665 or else In_Main_Context (Current_Scope)) 3666 and then Nkind (Parent (N)) /= N_Compilation_Unit 3667 then 3668 Inline_Now := True; 3669 3670 elsif Debug_Flag_Dot_K 3671 and then Must_Inline_Subp 3672 and then (Is_In_Main_Unit (N) 3673 or else In_Main_Context (Current_Scope)) 3674 and then Nkind (Parent (N)) /= N_Compilation_Unit 3675 then 3676 Inline_Now := True; 3677 3678 -- In configurable_run_time mode we force the inlining of 3679 -- predefined subprograms marked Inline_Always, to minimize 3680 -- the use of the run-time library. 3681 3682 elsif Is_Predefined_File_Name 3683 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 3684 and then Configurable_Run_Time_Mode 3685 and then Nkind (Parent (N)) /= N_Compilation_Unit 3686 then 3687 Inline_Now := True; 3688 end if; 3689 3690 -- If the current scope is itself an instance within a child 3691 -- unit, there will be duplications in the scope stack, and the 3692 -- unstacking mechanism in Inline_Instance_Body will fail. 3693 -- This loses some rare cases of optimization, and might be 3694 -- improved some day, if we can find a proper abstraction for 3695 -- "the complete compilation context" that can be saved and 3696 -- restored. ??? 3697 3698 if Is_Generic_Instance (Current_Scope) then 3699 declare 3700 Curr_Unit : constant Entity_Id := 3701 Cunit_Entity (Current_Sem_Unit); 3702 begin 3703 if Curr_Unit /= Current_Scope 3704 and then Is_Child_Unit (Curr_Unit) 3705 then 3706 Inline_Now := False; 3707 end if; 3708 end; 3709 end if; 3710 end if; 3711 3712 Needs_Body := 3713 (Unit_Requires_Body (Gen_Unit) 3714 or else Enclosing_Body_Present 3715 or else Present (Corresponding_Body (Gen_Decl))) 3716 and then (Is_In_Main_Unit (N) 3717 or else Might_Inline_Subp) 3718 and then not Is_Actual_Pack 3719 and then not Inline_Now 3720 and then (Operating_Mode = Generate_Code 3721 or else (Operating_Mode = Check_Semantics 3722 and then ASIS_Mode)); 3723 3724 -- If front_end_inlining is enabled, do not instantiate body if 3725 -- within a generic context. 3726 3727 if (Front_End_Inlining 3728 and then not Expander_Active) 3729 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 3730 then 3731 Needs_Body := False; 3732 end if; 3733 3734 -- If the current context is generic, and the package being 3735 -- instantiated is declared within a formal package, there is no 3736 -- body to instantiate until the enclosing generic is instantiated 3737 -- and there is an actual for the formal package. If the formal 3738 -- package has parameters, we build a regular package instance for 3739 -- it, that precedes the original formal package declaration. 3740 3741 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 3742 declare 3743 Decl : constant Node_Id := 3744 Original_Node 3745 (Unit_Declaration_Node (Scope (Gen_Unit))); 3746 begin 3747 if Nkind (Decl) = N_Formal_Package_Declaration 3748 or else (Nkind (Decl) = N_Package_Declaration 3749 and then Is_List_Member (Decl) 3750 and then Present (Next (Decl)) 3751 and then 3752 Nkind (Next (Decl)) = 3753 N_Formal_Package_Declaration) 3754 then 3755 Needs_Body := False; 3756 end if; 3757 end; 3758 end if; 3759 end; 3760 3761 -- For RCI unit calling stubs, we omit the instance body if the 3762 -- instance is the RCI library unit itself. 3763 3764 -- However there is a special case for nested instances: in this case 3765 -- we do generate the instance body, as it might be required, e.g. 3766 -- because it provides stream attributes for some type used in the 3767 -- profile of a remote subprogram. This is consistent with 12.3(12), 3768 -- which indicates that the instance body occurs at the place of the 3769 -- instantiation, and thus is part of the RCI declaration, which is 3770 -- present on all client partitions (this is E.2.3(18)). 3771 3772 -- Note that AI12-0002 may make it illegal at some point to have 3773 -- stream attributes defined in an RCI unit, in which case this 3774 -- special case will become unnecessary. In the meantime, there 3775 -- is known application code in production that depends on this 3776 -- being possible, so we definitely cannot eliminate the body in 3777 -- the case of nested instances for the time being. 3778 3779 -- When we generate a nested instance body, calling stubs for any 3780 -- relevant subprogram will be be inserted immediately after the 3781 -- subprogram declarations, and will take precedence over the 3782 -- subsequent (original) body. (The stub and original body will be 3783 -- complete homographs, but this is permitted in an instance). 3784 -- (Could we do better and remove the original body???) 3785 3786 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 3787 and then Comes_From_Source (N) 3788 and then Nkind (Parent (N)) = N_Compilation_Unit 3789 then 3790 Needs_Body := False; 3791 end if; 3792 3793 if Needs_Body then 3794 3795 -- Here is a defence against a ludicrous number of instantiations 3796 -- caused by a circular set of instantiation attempts. 3797 3798 if Pending_Instantiations.Last > Maximum_Instantiations then 3799 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 3800 Error_Msg_N ("too many instantiations, exceeds max of^", N); 3801 Error_Msg_N ("\limit can be changed using -gnateinn switch", N); 3802 raise Unrecoverable_Error; 3803 end if; 3804 3805 -- Indicate that the enclosing scopes contain an instantiation, 3806 -- and that cleanup actions should be delayed until after the 3807 -- instance body is expanded. 3808 3809 Check_Forward_Instantiation (Gen_Decl); 3810 if Nkind (N) = N_Package_Instantiation then 3811 declare 3812 Enclosing_Master : Entity_Id; 3813 3814 begin 3815 -- Loop to search enclosing masters 3816 3817 Enclosing_Master := Current_Scope; 3818 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 3819 if Ekind (Enclosing_Master) = E_Package then 3820 if Is_Compilation_Unit (Enclosing_Master) then 3821 if In_Package_Body (Enclosing_Master) then 3822 Delay_Descriptors 3823 (Body_Entity (Enclosing_Master)); 3824 else 3825 Delay_Descriptors 3826 (Enclosing_Master); 3827 end if; 3828 3829 exit Scope_Loop; 3830 3831 else 3832 Enclosing_Master := Scope (Enclosing_Master); 3833 end if; 3834 3835 elsif Is_Generic_Unit (Enclosing_Master) 3836 or else Ekind (Enclosing_Master) = E_Void 3837 then 3838 -- Cleanup actions will eventually be performed on the 3839 -- enclosing subprogram or package instance, if any. 3840 -- Enclosing scope is void in the formal part of a 3841 -- generic subprogram. 3842 3843 exit Scope_Loop; 3844 3845 else 3846 if Ekind (Enclosing_Master) = E_Entry 3847 and then 3848 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 3849 then 3850 if not Expander_Active then 3851 exit Scope_Loop; 3852 else 3853 Enclosing_Master := 3854 Protected_Body_Subprogram (Enclosing_Master); 3855 end if; 3856 end if; 3857 3858 Set_Delay_Cleanups (Enclosing_Master); 3859 3860 while Ekind (Enclosing_Master) = E_Block loop 3861 Enclosing_Master := Scope (Enclosing_Master); 3862 end loop; 3863 3864 if Is_Subprogram (Enclosing_Master) then 3865 Delay_Descriptors (Enclosing_Master); 3866 3867 elsif Is_Task_Type (Enclosing_Master) then 3868 declare 3869 TBP : constant Node_Id := 3870 Get_Task_Body_Procedure 3871 (Enclosing_Master); 3872 begin 3873 if Present (TBP) then 3874 Delay_Descriptors (TBP); 3875 Set_Delay_Cleanups (TBP); 3876 end if; 3877 end; 3878 end if; 3879 3880 exit Scope_Loop; 3881 end if; 3882 end loop Scope_Loop; 3883 end; 3884 3885 -- Make entry in table 3886 3887 Pending_Instantiations.Append 3888 ((Inst_Node => N, 3889 Act_Decl => Act_Decl, 3890 Expander_Status => Expander_Active, 3891 Current_Sem_Unit => Current_Sem_Unit, 3892 Scope_Suppress => Scope_Suppress, 3893 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 3894 Version => Ada_Version)); 3895 end if; 3896 end if; 3897 3898 Set_Categorization_From_Pragmas (Act_Decl); 3899 3900 if Parent_Installed then 3901 Hide_Current_Scope; 3902 end if; 3903 3904 Set_Instance_Spec (N, Act_Decl); 3905 3906 -- If not a compilation unit, insert the package declaration before 3907 -- the original instantiation node. 3908 3909 if Nkind (Parent (N)) /= N_Compilation_Unit then 3910 Mark_Rewrite_Insertion (Act_Decl); 3911 Insert_Before (N, Act_Decl); 3912 Analyze (Act_Decl); 3913 3914 -- For an instantiation that is a compilation unit, place 3915 -- declaration on current node so context is complete for analysis 3916 -- (including nested instantiations). If this is the main unit, 3917 -- the declaration eventually replaces the instantiation node. 3918 -- If the instance body is created later, it replaces the 3919 -- instance node, and the declaration is attached to it 3920 -- (see Build_Instance_Compilation_Unit_Nodes). 3921 3922 else 3923 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 3924 3925 -- The entity for the current unit is the newly created one, 3926 -- and all semantic information is attached to it. 3927 3928 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 3929 3930 -- If this is the main unit, replace the main entity as well 3931 3932 if Current_Sem_Unit = Main_Unit then 3933 Main_Unit_Entity := Act_Decl_Id; 3934 end if; 3935 end if; 3936 3937 Set_Unit (Parent (N), Act_Decl); 3938 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 3939 Set_Package_Instantiation (Act_Decl_Id, N); 3940 Analyze (Act_Decl); 3941 Set_Unit (Parent (N), N); 3942 Set_Body_Required (Parent (N), False); 3943 3944 -- We never need elaboration checks on instantiations, since by 3945 -- definition, the body instantiation is elaborated at the same 3946 -- time as the spec instantiation. 3947 3948 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 3949 Set_Kill_Elaboration_Checks (Act_Decl_Id); 3950 end if; 3951 3952 Check_Elab_Instantiation (N); 3953 3954 if ABE_Is_Certain (N) and then Needs_Body then 3955 Pending_Instantiations.Decrement_Last; 3956 end if; 3957 3958 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 3959 3960 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 3961 First_Private_Entity (Act_Decl_Id)); 3962 3963 -- If the instantiation will receive a body, the unit will be 3964 -- transformed into a package body, and receive its own elaboration 3965 -- entity. Otherwise, the nature of the unit is now a package 3966 -- declaration. 3967 3968 if Nkind (Parent (N)) = N_Compilation_Unit 3969 and then not Needs_Body 3970 then 3971 Rewrite (N, Act_Decl); 3972 end if; 3973 3974 if Present (Corresponding_Body (Gen_Decl)) 3975 or else Unit_Requires_Body (Gen_Unit) 3976 then 3977 Set_Has_Completion (Act_Decl_Id); 3978 end if; 3979 3980 Check_Formal_Packages (Act_Decl_Id); 3981 3982 Restore_Hidden_Primitives (Vis_Prims_List); 3983 Restore_Private_Views (Act_Decl_Id); 3984 3985 Inherit_Context (Gen_Decl, N); 3986 3987 if Parent_Installed then 3988 Remove_Parent; 3989 end if; 3990 3991 Restore_Env; 3992 Env_Installed := False; 3993 end if; 3994 3995 Validate_Categorization_Dependency (N, Act_Decl_Id); 3996 3997 -- There used to be a check here to prevent instantiations in local 3998 -- contexts if the No_Local_Allocators restriction was active. This 3999 -- check was removed by a binding interpretation in AI-95-00130/07, 4000 -- but we retain the code for documentation purposes. 4001 4002 -- if Ekind (Act_Decl_Id) /= E_Void 4003 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4004 -- then 4005 -- Check_Restriction (No_Local_Allocators, N); 4006 -- end if; 4007 4008 if Inline_Now then 4009 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4010 end if; 4011 4012 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4013 -- be used as defining identifiers for a formal package and for the 4014 -- corresponding expanded package. 4015 4016 if Nkind (N) = N_Formal_Package_Declaration then 4017 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4018 Set_Comes_From_Source (Act_Decl_Id, True); 4019 Set_Is_Generic_Instance (Act_Decl_Id, False); 4020 Set_Defining_Identifier (N, Act_Decl_Id); 4021 end if; 4022 4023 Style_Check := Save_Style_Check; 4024 4025 -- Check that if N is an instantiation of System.Dim_Float_IO or 4026 -- System.Dim_Integer_IO, the formal type has a dimension system. 4027 4028 if Nkind (N) = N_Package_Instantiation 4029 and then Is_Dim_IO_Package_Instantiation (N) 4030 then 4031 declare 4032 Assoc : constant Node_Id := First (Generic_Associations (N)); 4033 begin 4034 if not Has_Dimension_System 4035 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4036 then 4037 Error_Msg_N ("type with a dimension system expected", Assoc); 4038 end if; 4039 end; 4040 end if; 4041 4042 <<Leave>> 4043 if Has_Aspects (N) then 4044 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4045 end if; 4046 4047 exception 4048 when Instantiation_Error => 4049 if Parent_Installed then 4050 Remove_Parent; 4051 end if; 4052 4053 if Env_Installed then 4054 Restore_Env; 4055 end if; 4056 4057 Style_Check := Save_Style_Check; 4058 end Analyze_Package_Instantiation; 4059 4060 -------------------------- 4061 -- Inline_Instance_Body -- 4062 -------------------------- 4063 4064 procedure Inline_Instance_Body 4065 (N : Node_Id; 4066 Gen_Unit : Entity_Id; 4067 Act_Decl : Node_Id) 4068 is 4069 Vis : Boolean; 4070 Gen_Comp : constant Entity_Id := 4071 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4072 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4073 Curr_Scope : Entity_Id := Empty; 4074 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4075 Removed : Boolean := False; 4076 Num_Scopes : Int := 0; 4077 4078 Scope_Stack_Depth : constant Int := 4079 Scope_Stack.Last - Scope_Stack.First + 1; 4080 4081 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4082 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4083 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4084 Num_Inner : Int := 0; 4085 N_Instances : Int := 0; 4086 S : Entity_Id; 4087 4088 begin 4089 -- Case of generic unit defined in another unit. We must remove the 4090 -- complete context of the current unit to install that of the generic. 4091 4092 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4093 4094 -- Add some comments for the following two loops ??? 4095 4096 S := Current_Scope; 4097 while Present (S) and then S /= Standard_Standard loop 4098 loop 4099 Num_Scopes := Num_Scopes + 1; 4100 4101 Use_Clauses (Num_Scopes) := 4102 (Scope_Stack.Table 4103 (Scope_Stack.Last - Num_Scopes + 1). 4104 First_Use_Clause); 4105 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4106 4107 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4108 or else Scope_Stack.Table 4109 (Scope_Stack.Last - Num_Scopes).Entity 4110 = Scope (S); 4111 end loop; 4112 4113 exit when Is_Generic_Instance (S) 4114 and then (In_Package_Body (S) 4115 or else Ekind (S) = E_Procedure 4116 or else Ekind (S) = E_Function); 4117 S := Scope (S); 4118 end loop; 4119 4120 Vis := Is_Immediately_Visible (Gen_Comp); 4121 4122 -- Find and save all enclosing instances 4123 4124 S := Current_Scope; 4125 4126 while Present (S) 4127 and then S /= Standard_Standard 4128 loop 4129 if Is_Generic_Instance (S) then 4130 N_Instances := N_Instances + 1; 4131 Instances (N_Instances) := S; 4132 4133 exit when In_Package_Body (S); 4134 end if; 4135 4136 S := Scope (S); 4137 end loop; 4138 4139 -- Remove context of current compilation unit, unless we are within a 4140 -- nested package instantiation, in which case the context has been 4141 -- removed previously. 4142 4143 -- If current scope is the body of a child unit, remove context of 4144 -- spec as well. If an enclosing scope is an instance body, the 4145 -- context has already been removed, but the entities in the body 4146 -- must be made invisible as well. 4147 4148 S := Current_Scope; 4149 4150 while Present (S) 4151 and then S /= Standard_Standard 4152 loop 4153 if Is_Generic_Instance (S) 4154 and then (In_Package_Body (S) 4155 or else Ekind (S) = E_Procedure 4156 or else Ekind (S) = E_Function) 4157 then 4158 -- We still have to remove the entities of the enclosing 4159 -- instance from direct visibility. 4160 4161 declare 4162 E : Entity_Id; 4163 begin 4164 E := First_Entity (S); 4165 while Present (E) loop 4166 Set_Is_Immediately_Visible (E, False); 4167 Next_Entity (E); 4168 end loop; 4169 end; 4170 4171 exit; 4172 end if; 4173 4174 if S = Curr_Unit 4175 or else (Ekind (Curr_Unit) = E_Package_Body 4176 and then S = Spec_Entity (Curr_Unit)) 4177 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4178 and then S = 4179 Corresponding_Spec 4180 (Unit_Declaration_Node (Curr_Unit))) 4181 then 4182 Removed := True; 4183 4184 -- Remove entities in current scopes from visibility, so that 4185 -- instance body is compiled in a clean environment. 4186 4187 Save_Scope_Stack (Handle_Use => False); 4188 4189 if Is_Child_Unit (S) then 4190 4191 -- Remove child unit from stack, as well as inner scopes. 4192 -- Removing the context of a child unit removes parent units 4193 -- as well. 4194 4195 while Current_Scope /= S loop 4196 Num_Inner := Num_Inner + 1; 4197 Inner_Scopes (Num_Inner) := Current_Scope; 4198 Pop_Scope; 4199 end loop; 4200 4201 Pop_Scope; 4202 Remove_Context (Curr_Comp); 4203 Curr_Scope := S; 4204 4205 else 4206 Remove_Context (Curr_Comp); 4207 end if; 4208 4209 if Ekind (Curr_Unit) = E_Package_Body then 4210 Remove_Context (Library_Unit (Curr_Comp)); 4211 end if; 4212 end if; 4213 4214 S := Scope (S); 4215 end loop; 4216 pragma Assert (Num_Inner < Num_Scopes); 4217 4218 Push_Scope (Standard_Standard); 4219 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 4220 Instantiate_Package_Body 4221 (Body_Info => 4222 ((Inst_Node => N, 4223 Act_Decl => Act_Decl, 4224 Expander_Status => Expander_Active, 4225 Current_Sem_Unit => Current_Sem_Unit, 4226 Scope_Suppress => Scope_Suppress, 4227 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4228 Version => Ada_Version)), 4229 Inlined_Body => True); 4230 4231 Pop_Scope; 4232 4233 -- Restore context 4234 4235 Set_Is_Immediately_Visible (Gen_Comp, Vis); 4236 4237 -- Reset Generic_Instance flag so that use clauses can be installed 4238 -- in the proper order. (See Use_One_Package for effect of enclosing 4239 -- instances on processing of use clauses). 4240 4241 for J in 1 .. N_Instances loop 4242 Set_Is_Generic_Instance (Instances (J), False); 4243 end loop; 4244 4245 if Removed then 4246 Install_Context (Curr_Comp); 4247 4248 if Present (Curr_Scope) 4249 and then Is_Child_Unit (Curr_Scope) 4250 then 4251 Push_Scope (Curr_Scope); 4252 Set_Is_Immediately_Visible (Curr_Scope); 4253 4254 -- Finally, restore inner scopes as well 4255 4256 for J in reverse 1 .. Num_Inner loop 4257 Push_Scope (Inner_Scopes (J)); 4258 end loop; 4259 end if; 4260 4261 Restore_Scope_Stack (Handle_Use => False); 4262 4263 if Present (Curr_Scope) 4264 and then 4265 (In_Private_Part (Curr_Scope) 4266 or else In_Package_Body (Curr_Scope)) 4267 then 4268 -- Install private declaration of ancestor units, which are 4269 -- currently available. Restore_Scope_Stack and Install_Context 4270 -- only install the visible part of parents. 4271 4272 declare 4273 Par : Entity_Id; 4274 begin 4275 Par := Scope (Curr_Scope); 4276 while (Present (Par)) 4277 and then Par /= Standard_Standard 4278 loop 4279 Install_Private_Declarations (Par); 4280 Par := Scope (Par); 4281 end loop; 4282 end; 4283 end if; 4284 end if; 4285 4286 -- Restore use clauses. For a child unit, use clauses in the parents 4287 -- are restored when installing the context, so only those in inner 4288 -- scopes (and those local to the child unit itself) need to be 4289 -- installed explicitly. 4290 4291 if Is_Child_Unit (Curr_Unit) 4292 and then Removed 4293 then 4294 for J in reverse 1 .. Num_Inner + 1 loop 4295 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4296 Use_Clauses (J); 4297 Install_Use_Clauses (Use_Clauses (J)); 4298 end loop; 4299 4300 else 4301 for J in reverse 1 .. Num_Scopes loop 4302 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4303 Use_Clauses (J); 4304 Install_Use_Clauses (Use_Clauses (J)); 4305 end loop; 4306 end if; 4307 4308 -- Restore status of instances. If one of them is a body, make 4309 -- its local entities visible again. 4310 4311 declare 4312 E : Entity_Id; 4313 Inst : Entity_Id; 4314 4315 begin 4316 for J in 1 .. N_Instances loop 4317 Inst := Instances (J); 4318 Set_Is_Generic_Instance (Inst, True); 4319 4320 if In_Package_Body (Inst) 4321 or else Ekind (S) = E_Procedure 4322 or else Ekind (S) = E_Function 4323 then 4324 E := First_Entity (Instances (J)); 4325 while Present (E) loop 4326 Set_Is_Immediately_Visible (E); 4327 Next_Entity (E); 4328 end loop; 4329 end if; 4330 end loop; 4331 end; 4332 4333 -- If generic unit is in current unit, current context is correct 4334 4335 else 4336 Instantiate_Package_Body 4337 (Body_Info => 4338 ((Inst_Node => N, 4339 Act_Decl => Act_Decl, 4340 Expander_Status => Expander_Active, 4341 Current_Sem_Unit => Current_Sem_Unit, 4342 Scope_Suppress => Scope_Suppress, 4343 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4344 Version => Ada_Version)), 4345 Inlined_Body => True); 4346 end if; 4347 end Inline_Instance_Body; 4348 4349 ------------------------------------- 4350 -- Analyze_Procedure_Instantiation -- 4351 ------------------------------------- 4352 4353 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 4354 begin 4355 Analyze_Subprogram_Instantiation (N, E_Procedure); 4356 end Analyze_Procedure_Instantiation; 4357 4358 ----------------------------------- 4359 -- Need_Subprogram_Instance_Body -- 4360 ----------------------------------- 4361 4362 function Need_Subprogram_Instance_Body 4363 (N : Node_Id; 4364 Subp : Entity_Id) return Boolean 4365 is 4366 begin 4367 if (Is_In_Main_Unit (N) 4368 or else Is_Inlined (Subp) 4369 or else Is_Inlined (Alias (Subp))) 4370 and then (Operating_Mode = Generate_Code 4371 or else (Operating_Mode = Check_Semantics 4372 and then ASIS_Mode)) 4373 and then (Full_Expander_Active or else ASIS_Mode) 4374 and then not ABE_Is_Certain (N) 4375 and then not Is_Eliminated (Subp) 4376 then 4377 Pending_Instantiations.Append 4378 ((Inst_Node => N, 4379 Act_Decl => Unit_Declaration_Node (Subp), 4380 Expander_Status => Expander_Active, 4381 Current_Sem_Unit => Current_Sem_Unit, 4382 Scope_Suppress => Scope_Suppress, 4383 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4384 Version => Ada_Version)); 4385 return True; 4386 4387 else 4388 return False; 4389 end if; 4390 end Need_Subprogram_Instance_Body; 4391 4392 -------------------------------------- 4393 -- Analyze_Subprogram_Instantiation -- 4394 -------------------------------------- 4395 4396 procedure Analyze_Subprogram_Instantiation 4397 (N : Node_Id; 4398 K : Entity_Kind) 4399 is 4400 Loc : constant Source_Ptr := Sloc (N); 4401 Gen_Id : constant Node_Id := Name (N); 4402 4403 Anon_Id : constant Entity_Id := 4404 Make_Defining_Identifier (Sloc (Defining_Entity (N)), 4405 Chars => New_External_Name 4406 (Chars (Defining_Entity (N)), 'R')); 4407 4408 Act_Decl_Id : Entity_Id; 4409 Act_Decl : Node_Id; 4410 Act_Spec : Node_Id; 4411 Act_Tree : Node_Id; 4412 4413 Env_Installed : Boolean := False; 4414 Gen_Unit : Entity_Id; 4415 Gen_Decl : Node_Id; 4416 Pack_Id : Entity_Id; 4417 Parent_Installed : Boolean := False; 4418 Renaming_List : List_Id; 4419 4420 procedure Analyze_Instance_And_Renamings; 4421 -- The instance must be analyzed in a context that includes the mappings 4422 -- of generic parameters into actuals. We create a package declaration 4423 -- for this purpose, and a subprogram with an internal name within the 4424 -- package. The subprogram instance is simply an alias for the internal 4425 -- subprogram, declared in the current scope. 4426 4427 ------------------------------------ 4428 -- Analyze_Instance_And_Renamings -- 4429 ------------------------------------ 4430 4431 procedure Analyze_Instance_And_Renamings is 4432 Def_Ent : constant Entity_Id := Defining_Entity (N); 4433 Pack_Decl : Node_Id; 4434 4435 begin 4436 if Nkind (Parent (N)) = N_Compilation_Unit then 4437 4438 -- For the case of a compilation unit, the container package has 4439 -- the same name as the instantiation, to insure that the binder 4440 -- calls the elaboration procedure with the right name. Copy the 4441 -- entity of the instance, which may have compilation level flags 4442 -- (e.g. Is_Child_Unit) set. 4443 4444 Pack_Id := New_Copy (Def_Ent); 4445 4446 else 4447 -- Otherwise we use the name of the instantiation concatenated 4448 -- with its source position to ensure uniqueness if there are 4449 -- several instantiations with the same name. 4450 4451 Pack_Id := 4452 Make_Defining_Identifier (Loc, 4453 Chars => New_External_Name 4454 (Related_Id => Chars (Def_Ent), 4455 Suffix => "GP", 4456 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 4457 end if; 4458 4459 Pack_Decl := Make_Package_Declaration (Loc, 4460 Specification => Make_Package_Specification (Loc, 4461 Defining_Unit_Name => Pack_Id, 4462 Visible_Declarations => Renaming_List, 4463 End_Label => Empty)); 4464 4465 Set_Instance_Spec (N, Pack_Decl); 4466 Set_Is_Generic_Instance (Pack_Id); 4467 Set_Debug_Info_Needed (Pack_Id); 4468 4469 -- Case of not a compilation unit 4470 4471 if Nkind (Parent (N)) /= N_Compilation_Unit then 4472 Mark_Rewrite_Insertion (Pack_Decl); 4473 Insert_Before (N, Pack_Decl); 4474 Set_Has_Completion (Pack_Id); 4475 4476 -- Case of an instantiation that is a compilation unit 4477 4478 -- Place declaration on current node so context is complete for 4479 -- analysis (including nested instantiations), and for use in a 4480 -- context_clause (see Analyze_With_Clause). 4481 4482 else 4483 Set_Unit (Parent (N), Pack_Decl); 4484 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 4485 end if; 4486 4487 Analyze (Pack_Decl); 4488 Check_Formal_Packages (Pack_Id); 4489 Set_Is_Generic_Instance (Pack_Id, False); 4490 4491 -- Why do we clear Is_Generic_Instance??? We set it 20 lines 4492 -- above??? 4493 4494 -- Body of the enclosing package is supplied when instantiating the 4495 -- subprogram body, after semantic analysis is completed. 4496 4497 if Nkind (Parent (N)) = N_Compilation_Unit then 4498 4499 -- Remove package itself from visibility, so it does not 4500 -- conflict with subprogram. 4501 4502 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 4503 4504 -- Set name and scope of internal subprogram so that the proper 4505 -- external name will be generated. The proper scope is the scope 4506 -- of the wrapper package. We need to generate debugging info for 4507 -- the internal subprogram, so set flag accordingly. 4508 4509 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 4510 Set_Scope (Anon_Id, Scope (Pack_Id)); 4511 4512 -- Mark wrapper package as referenced, to avoid spurious warnings 4513 -- if the instantiation appears in various with_ clauses of 4514 -- subunits of the main unit. 4515 4516 Set_Referenced (Pack_Id); 4517 end if; 4518 4519 Set_Is_Generic_Instance (Anon_Id); 4520 Set_Debug_Info_Needed (Anon_Id); 4521 Act_Decl_Id := New_Copy (Anon_Id); 4522 4523 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4524 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 4525 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 4526 Set_Comes_From_Source (Act_Decl_Id, True); 4527 4528 -- The signature may involve types that are not frozen yet, but the 4529 -- subprogram will be frozen at the point the wrapper package is 4530 -- frozen, so it does not need its own freeze node. In fact, if one 4531 -- is created, it might conflict with the freezing actions from the 4532 -- wrapper package. 4533 4534 Set_Has_Delayed_Freeze (Anon_Id, False); 4535 4536 -- If the instance is a child unit, mark the Id accordingly. Mark 4537 -- the anonymous entity as well, which is the real subprogram and 4538 -- which is used when the instance appears in a context clause. 4539 -- Similarly, propagate the Is_Eliminated flag to handle properly 4540 -- nested eliminated subprograms. 4541 4542 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 4543 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 4544 New_Overloaded_Entity (Act_Decl_Id); 4545 Check_Eliminated (Act_Decl_Id); 4546 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 4547 4548 -- In compilation unit case, kill elaboration checks on the 4549 -- instantiation, since they are never needed -- the body is 4550 -- instantiated at the same point as the spec. 4551 4552 if Nkind (Parent (N)) = N_Compilation_Unit then 4553 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4554 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4555 Set_Is_Compilation_Unit (Anon_Id); 4556 4557 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 4558 end if; 4559 4560 -- The instance is not a freezing point for the new subprogram 4561 4562 Set_Is_Frozen (Act_Decl_Id, False); 4563 4564 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 4565 Valid_Operator_Definition (Act_Decl_Id); 4566 end if; 4567 4568 Set_Alias (Act_Decl_Id, Anon_Id); 4569 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4570 Set_Has_Completion (Act_Decl_Id); 4571 Set_Related_Instance (Pack_Id, Act_Decl_Id); 4572 4573 if Nkind (Parent (N)) = N_Compilation_Unit then 4574 Set_Body_Required (Parent (N), False); 4575 end if; 4576 end Analyze_Instance_And_Renamings; 4577 4578 -- Local variables 4579 4580 Vis_Prims_List : Elist_Id := No_Elist; 4581 -- List of primitives made temporarily visible in the instantiation 4582 -- to match the visibility of the formal type 4583 4584 -- Start of processing for Analyze_Subprogram_Instantiation 4585 4586 begin 4587 Check_SPARK_Restriction ("generic is not allowed", N); 4588 4589 -- Very first thing: apply the special kludge for Text_IO processing 4590 -- in case we are instantiating one of the children of [Wide_]Text_IO. 4591 -- Of course such an instantiation is bogus (these are packages, not 4592 -- subprograms), but we get a better error message if we do this. 4593 4594 Text_IO_Kludge (Gen_Id); 4595 4596 -- Make node global for error reporting 4597 4598 Instantiation_Node := N; 4599 4600 -- For package instantiations we turn off style checks, because they 4601 -- will have been emitted in the generic. For subprogram instantiations 4602 -- we want to apply at least the check on overriding indicators so we 4603 -- do not modify the style check status. 4604 4605 -- The renaming declarations for the actuals do not come from source and 4606 -- will not generate spurious warnings. 4607 4608 Preanalyze_Actuals (N); 4609 4610 Init_Env; 4611 Env_Installed := True; 4612 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 4613 Gen_Unit := Entity (Gen_Id); 4614 4615 Generate_Reference (Gen_Unit, Gen_Id); 4616 4617 if Nkind (Gen_Id) = N_Identifier 4618 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 4619 then 4620 Error_Msg_NE 4621 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 4622 end if; 4623 4624 if Etype (Gen_Unit) = Any_Type then 4625 Restore_Env; 4626 return; 4627 end if; 4628 4629 -- Verify that it is a generic subprogram of the right kind, and that 4630 -- it does not lead to a circular instantiation. 4631 4632 if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then 4633 Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); 4634 4635 elsif In_Open_Scopes (Gen_Unit) then 4636 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 4637 4638 elsif K = E_Procedure 4639 and then Ekind (Gen_Unit) /= E_Generic_Procedure 4640 then 4641 if Ekind (Gen_Unit) = E_Generic_Function then 4642 Error_Msg_N 4643 ("cannot instantiate generic function as procedure", Gen_Id); 4644 else 4645 Error_Msg_N 4646 ("expect name of generic procedure in instantiation", Gen_Id); 4647 end if; 4648 4649 elsif K = E_Function 4650 and then Ekind (Gen_Unit) /= E_Generic_Function 4651 then 4652 if Ekind (Gen_Unit) = E_Generic_Procedure then 4653 Error_Msg_N 4654 ("cannot instantiate generic procedure as function", Gen_Id); 4655 else 4656 Error_Msg_N 4657 ("expect name of generic function in instantiation", Gen_Id); 4658 end if; 4659 4660 else 4661 Set_Entity (Gen_Id, Gen_Unit); 4662 Set_Is_Instantiated (Gen_Unit); 4663 4664 if In_Extended_Main_Source_Unit (N) then 4665 Generate_Reference (Gen_Unit, N); 4666 end if; 4667 4668 -- If renaming, get original unit 4669 4670 if Present (Renamed_Object (Gen_Unit)) 4671 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure 4672 or else 4673 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function) 4674 then 4675 Gen_Unit := Renamed_Object (Gen_Unit); 4676 Set_Is_Instantiated (Gen_Unit); 4677 Generate_Reference (Gen_Unit, N); 4678 end if; 4679 4680 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 4681 Error_Msg_Node_2 := Current_Scope; 4682 Error_Msg_NE 4683 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 4684 Circularity_Detected := True; 4685 Restore_Hidden_Primitives (Vis_Prims_List); 4686 goto Leave; 4687 end if; 4688 4689 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 4690 4691 -- Initialize renamings map, for error checking 4692 4693 Generic_Renamings.Set_Last (0); 4694 Generic_Renamings_HTable.Reset; 4695 4696 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 4697 4698 -- Copy original generic tree, to produce text for instantiation 4699 4700 Act_Tree := 4701 Copy_Generic_Node 4702 (Original_Node (Gen_Decl), Empty, Instantiating => True); 4703 4704 -- Inherit overriding indicator from instance node 4705 4706 Act_Spec := Specification (Act_Tree); 4707 Set_Must_Override (Act_Spec, Must_Override (N)); 4708 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 4709 4710 Renaming_List := 4711 Analyze_Associations 4712 (I_Node => N, 4713 Formals => Generic_Formal_Declarations (Act_Tree), 4714 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 4715 4716 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 4717 4718 -- The subprogram itself cannot contain a nested instance, so the 4719 -- current parent is left empty. 4720 4721 Set_Instance_Env (Gen_Unit, Empty); 4722 4723 -- Build the subprogram declaration, which does not appear in the 4724 -- generic template, and give it a sloc consistent with that of the 4725 -- template. 4726 4727 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 4728 Set_Generic_Parent (Act_Spec, Gen_Unit); 4729 Act_Decl := 4730 Make_Subprogram_Declaration (Sloc (Act_Spec), 4731 Specification => Act_Spec); 4732 4733 -- The aspects have been copied previously, but they have to be 4734 -- linked explicitly to the new subprogram declaration. Explicit 4735 -- pre/postconditions on the instance are analyzed below, in a 4736 -- separate step. 4737 4738 Move_Aspects (Act_Tree, Act_Decl); 4739 Set_Categorization_From_Pragmas (Act_Decl); 4740 4741 if Parent_Installed then 4742 Hide_Current_Scope; 4743 end if; 4744 4745 Append (Act_Decl, Renaming_List); 4746 Analyze_Instance_And_Renamings; 4747 4748 -- If the generic is marked Import (Intrinsic), then so is the 4749 -- instance. This indicates that there is no body to instantiate. If 4750 -- generic is marked inline, so it the instance, and the anonymous 4751 -- subprogram it renames. If inlined, or else if inlining is enabled 4752 -- for the compilation, we generate the instance body even if it is 4753 -- not within the main unit. 4754 4755 if Is_Intrinsic_Subprogram (Gen_Unit) then 4756 Set_Is_Intrinsic_Subprogram (Anon_Id); 4757 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 4758 4759 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 4760 Validate_Unchecked_Conversion (N, Act_Decl_Id); 4761 end if; 4762 end if; 4763 4764 -- Inherit convention from generic unit. Intrinsic convention, as for 4765 -- an instance of unchecked conversion, is not inherited because an 4766 -- explicit Ada instance has been created. 4767 4768 if Has_Convention_Pragma (Gen_Unit) 4769 and then Convention (Gen_Unit) /= Convention_Intrinsic 4770 then 4771 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 4772 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 4773 end if; 4774 4775 Generate_Definition (Act_Decl_Id); 4776 -- Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); 4777 -- ??? needed? 4778 Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); 4779 4780 -- Inherit all inlining-related flags which apply to the generic in 4781 -- the subprogram and its declaration. 4782 4783 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 4784 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 4785 4786 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 4787 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 4788 4789 Set_Has_Pragma_Inline_Always 4790 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 4791 Set_Has_Pragma_Inline_Always 4792 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 4793 4794 if not Is_Intrinsic_Subprogram (Gen_Unit) then 4795 Check_Elab_Instantiation (N); 4796 end if; 4797 4798 if Is_Dispatching_Operation (Act_Decl_Id) 4799 and then Ada_Version >= Ada_2005 4800 then 4801 declare 4802 Formal : Entity_Id; 4803 4804 begin 4805 Formal := First_Formal (Act_Decl_Id); 4806 while Present (Formal) loop 4807 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 4808 and then Is_Controlling_Formal (Formal) 4809 and then not Can_Never_Be_Null (Formal) 4810 then 4811 Error_Msg_NE ("access parameter& is controlling,", 4812 N, Formal); 4813 Error_Msg_NE 4814 ("\corresponding parameter of & must be" 4815 & " explicitly null-excluding", N, Gen_Id); 4816 end if; 4817 4818 Next_Formal (Formal); 4819 end loop; 4820 end; 4821 end if; 4822 4823 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4824 4825 Validate_Categorization_Dependency (N, Act_Decl_Id); 4826 4827 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 4828 Inherit_Context (Gen_Decl, N); 4829 4830 Restore_Private_Views (Pack_Id, False); 4831 4832 -- If the context requires a full instantiation, mark node for 4833 -- subsequent construction of the body. 4834 4835 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 4836 4837 Check_Forward_Instantiation (Gen_Decl); 4838 4839 -- The wrapper package is always delayed, because it does not 4840 -- constitute a freeze point, but to insure that the freeze 4841 -- node is placed properly, it is created directly when 4842 -- instantiating the body (otherwise the freeze node might 4843 -- appear to early for nested instantiations). 4844 4845 elsif Nkind (Parent (N)) = N_Compilation_Unit then 4846 4847 -- For ASIS purposes, indicate that the wrapper package has 4848 -- replaced the instantiation node. 4849 4850 Rewrite (N, Unit (Parent (N))); 4851 Set_Unit (Parent (N), N); 4852 end if; 4853 4854 elsif Nkind (Parent (N)) = N_Compilation_Unit then 4855 4856 -- Replace instance node for library-level instantiations of 4857 -- intrinsic subprograms, for ASIS use. 4858 4859 Rewrite (N, Unit (Parent (N))); 4860 Set_Unit (Parent (N), N); 4861 end if; 4862 4863 if Parent_Installed then 4864 Remove_Parent; 4865 end if; 4866 4867 Restore_Hidden_Primitives (Vis_Prims_List); 4868 Restore_Env; 4869 Env_Installed := False; 4870 Generic_Renamings.Set_Last (0); 4871 Generic_Renamings_HTable.Reset; 4872 end if; 4873 4874 <<Leave>> 4875 if Has_Aspects (N) then 4876 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4877 end if; 4878 4879 exception 4880 when Instantiation_Error => 4881 if Parent_Installed then 4882 Remove_Parent; 4883 end if; 4884 4885 if Env_Installed then 4886 Restore_Env; 4887 end if; 4888 end Analyze_Subprogram_Instantiation; 4889 4890 ------------------------- 4891 -- Get_Associated_Node -- 4892 ------------------------- 4893 4894 function Get_Associated_Node (N : Node_Id) return Node_Id is 4895 Assoc : Node_Id; 4896 4897 begin 4898 Assoc := Associated_Node (N); 4899 4900 if Nkind (Assoc) /= Nkind (N) then 4901 return Assoc; 4902 4903 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 4904 return Assoc; 4905 4906 else 4907 -- If the node is part of an inner generic, it may itself have been 4908 -- remapped into a further generic copy. Associated_Node is otherwise 4909 -- used for the entity of the node, and will be of a different node 4910 -- kind, or else N has been rewritten as a literal or function call. 4911 4912 while Present (Associated_Node (Assoc)) 4913 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 4914 loop 4915 Assoc := Associated_Node (Assoc); 4916 end loop; 4917 4918 -- Follow and additional link in case the final node was rewritten. 4919 -- This can only happen with nested generic units. 4920 4921 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 4922 and then Present (Associated_Node (Assoc)) 4923 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 4924 N_Explicit_Dereference, 4925 N_Integer_Literal, 4926 N_Real_Literal, 4927 N_String_Literal)) 4928 then 4929 Assoc := Associated_Node (Assoc); 4930 end if; 4931 4932 -- An additional special case: an unconstrained type in an object 4933 -- declaration may have been rewritten as a local subtype constrained 4934 -- by the expression in the declaration. We need to recover the 4935 -- original entity which may be global. 4936 4937 if Present (Original_Node (Assoc)) 4938 and then Nkind (Parent (N)) = N_Object_Declaration 4939 then 4940 Assoc := Original_Node (Assoc); 4941 end if; 4942 4943 return Assoc; 4944 end if; 4945 end Get_Associated_Node; 4946 4947 ------------------------------------------- 4948 -- Build_Instance_Compilation_Unit_Nodes -- 4949 ------------------------------------------- 4950 4951 procedure Build_Instance_Compilation_Unit_Nodes 4952 (N : Node_Id; 4953 Act_Body : Node_Id; 4954 Act_Decl : Node_Id) 4955 is 4956 Decl_Cunit : Node_Id; 4957 Body_Cunit : Node_Id; 4958 Citem : Node_Id; 4959 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 4960 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 4961 4962 begin 4963 -- A new compilation unit node is built for the instance declaration 4964 4965 Decl_Cunit := 4966 Make_Compilation_Unit (Sloc (N), 4967 Context_Items => Empty_List, 4968 Unit => Act_Decl, 4969 Aux_Decls_Node => 4970 Make_Compilation_Unit_Aux (Sloc (N))); 4971 4972 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 4973 4974 -- The new compilation unit is linked to its body, but both share the 4975 -- same file, so we do not set Body_Required on the new unit so as not 4976 -- to create a spurious dependency on a non-existent body in the ali. 4977 -- This simplifies CodePeer unit traversal. 4978 4979 -- We use the original instantiation compilation unit as the resulting 4980 -- compilation unit of the instance, since this is the main unit. 4981 4982 Rewrite (N, Act_Body); 4983 Body_Cunit := Parent (N); 4984 4985 -- The two compilation unit nodes are linked by the Library_Unit field 4986 4987 Set_Library_Unit (Decl_Cunit, Body_Cunit); 4988 Set_Library_Unit (Body_Cunit, Decl_Cunit); 4989 4990 -- Preserve the private nature of the package if needed 4991 4992 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 4993 4994 -- If the instance is not the main unit, its context, categorization 4995 -- and elaboration entity are not relevant to the compilation. 4996 4997 if Body_Cunit /= Cunit (Main_Unit) then 4998 Make_Instance_Unit (Body_Cunit, In_Main => False); 4999 return; 5000 end if; 5001 5002 -- The context clause items on the instantiation, which are now attached 5003 -- to the body compilation unit (since the body overwrote the original 5004 -- instantiation node), semantically belong on the spec, so copy them 5005 -- there. It's harmless to leave them on the body as well. In fact one 5006 -- could argue that they belong in both places. 5007 5008 Citem := First (Context_Items (Body_Cunit)); 5009 while Present (Citem) loop 5010 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 5011 Next (Citem); 5012 end loop; 5013 5014 -- Propagate categorization flags on packages, so that they appear in 5015 -- the ali file for the spec of the unit. 5016 5017 if Ekind (New_Main) = E_Package then 5018 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 5019 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 5020 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 5021 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 5022 Set_Is_Remote_Call_Interface 5023 (Old_Main, Is_Remote_Call_Interface (New_Main)); 5024 end if; 5025 5026 -- Make entry in Units table, so that binder can generate call to 5027 -- elaboration procedure for body, if any. 5028 5029 Make_Instance_Unit (Body_Cunit, In_Main => True); 5030 Main_Unit_Entity := New_Main; 5031 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 5032 5033 -- Build elaboration entity, since the instance may certainly generate 5034 -- elaboration code requiring a flag for protection. 5035 5036 Build_Elaboration_Entity (Decl_Cunit, New_Main); 5037 end Build_Instance_Compilation_Unit_Nodes; 5038 5039 ----------------------------- 5040 -- Check_Access_Definition -- 5041 ----------------------------- 5042 5043 procedure Check_Access_Definition (N : Node_Id) is 5044 begin 5045 pragma Assert 5046 (Ada_Version >= Ada_2005 5047 and then Present (Access_Definition (N))); 5048 null; 5049 end Check_Access_Definition; 5050 5051 ----------------------------------- 5052 -- Check_Formal_Package_Instance -- 5053 ----------------------------------- 5054 5055 -- If the formal has specific parameters, they must match those of the 5056 -- actual. Both of them are instances, and the renaming declarations for 5057 -- their formal parameters appear in the same order in both. The analyzed 5058 -- formal has been analyzed in the context of the current instance. 5059 5060 procedure Check_Formal_Package_Instance 5061 (Formal_Pack : Entity_Id; 5062 Actual_Pack : Entity_Id) 5063 is 5064 E1 : Entity_Id := First_Entity (Actual_Pack); 5065 E2 : Entity_Id := First_Entity (Formal_Pack); 5066 5067 Expr1 : Node_Id; 5068 Expr2 : Node_Id; 5069 5070 procedure Check_Mismatch (B : Boolean); 5071 -- Common error routine for mismatch between the parameters of the 5072 -- actual instance and those of the formal package. 5073 5074 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 5075 -- The formal may come from a nested formal package, and the actual may 5076 -- have been constant-folded. To determine whether the two denote the 5077 -- same entity we may have to traverse several definitions to recover 5078 -- the ultimate entity that they refer to. 5079 5080 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 5081 -- Similarly, if the formal comes from a nested formal package, the 5082 -- actual may designate the formal through multiple renamings, which 5083 -- have to be followed to determine the original variable in question. 5084 5085 -------------------- 5086 -- Check_Mismatch -- 5087 -------------------- 5088 5089 procedure Check_Mismatch (B : Boolean) is 5090 Kind : constant Node_Kind := Nkind (Parent (E2)); 5091 5092 begin 5093 if Kind = N_Formal_Type_Declaration then 5094 return; 5095 5096 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 5097 N_Formal_Package_Declaration) 5098 or else Kind in N_Formal_Subprogram_Declaration 5099 then 5100 null; 5101 5102 elsif B then 5103 Error_Msg_NE 5104 ("actual for & in actual instance does not match formal", 5105 Parent (Actual_Pack), E1); 5106 end if; 5107 end Check_Mismatch; 5108 5109 -------------------------------- 5110 -- Same_Instantiated_Constant -- 5111 -------------------------------- 5112 5113 function Same_Instantiated_Constant 5114 (E1, E2 : Entity_Id) return Boolean 5115 is 5116 Ent : Entity_Id; 5117 5118 begin 5119 Ent := E2; 5120 while Present (Ent) loop 5121 if E1 = Ent then 5122 return True; 5123 5124 elsif Ekind (Ent) /= E_Constant then 5125 return False; 5126 5127 elsif Is_Entity_Name (Constant_Value (Ent)) then 5128 if Entity (Constant_Value (Ent)) = E1 then 5129 return True; 5130 else 5131 Ent := Entity (Constant_Value (Ent)); 5132 end if; 5133 5134 -- The actual may be a constant that has been folded. Recover 5135 -- original name. 5136 5137 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 5138 Ent := Entity (Original_Node (Constant_Value (Ent))); 5139 else 5140 return False; 5141 end if; 5142 end loop; 5143 5144 return False; 5145 end Same_Instantiated_Constant; 5146 5147 -------------------------------- 5148 -- Same_Instantiated_Variable -- 5149 -------------------------------- 5150 5151 function Same_Instantiated_Variable 5152 (E1, E2 : Entity_Id) return Boolean 5153 is 5154 function Original_Entity (E : Entity_Id) return Entity_Id; 5155 -- Follow chain of renamings to the ultimate ancestor 5156 5157 --------------------- 5158 -- Original_Entity -- 5159 --------------------- 5160 5161 function Original_Entity (E : Entity_Id) return Entity_Id is 5162 Orig : Entity_Id; 5163 5164 begin 5165 Orig := E; 5166 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 5167 and then Present (Renamed_Object (Orig)) 5168 and then Is_Entity_Name (Renamed_Object (Orig)) 5169 loop 5170 Orig := Entity (Renamed_Object (Orig)); 5171 end loop; 5172 5173 return Orig; 5174 end Original_Entity; 5175 5176 -- Start of processing for Same_Instantiated_Variable 5177 5178 begin 5179 return Ekind (E1) = Ekind (E2) 5180 and then Original_Entity (E1) = Original_Entity (E2); 5181 end Same_Instantiated_Variable; 5182 5183 -- Start of processing for Check_Formal_Package_Instance 5184 5185 begin 5186 while Present (E1) 5187 and then Present (E2) 5188 loop 5189 exit when Ekind (E1) = E_Package 5190 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 5191 5192 -- If the formal is the renaming of the formal package, this 5193 -- is the end of its formal part, which may occur before the 5194 -- end of the formal part in the actual in the presence of 5195 -- defaulted parameters in the formal package. 5196 5197 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 5198 and then Renamed_Entity (E2) = Scope (E2); 5199 5200 -- The analysis of the actual may generate additional internal 5201 -- entities. If the formal is defaulted, there is no corresponding 5202 -- analysis and the internal entities must be skipped, until we 5203 -- find corresponding entities again. 5204 5205 if Comes_From_Source (E2) 5206 and then not Comes_From_Source (E1) 5207 and then Chars (E1) /= Chars (E2) 5208 then 5209 while Present (E1) 5210 and then Chars (E1) /= Chars (E2) 5211 loop 5212 Next_Entity (E1); 5213 end loop; 5214 end if; 5215 5216 if No (E1) then 5217 return; 5218 5219 -- If the formal entity comes from a formal declaration, it was 5220 -- defaulted in the formal package, and no check is needed on it. 5221 5222 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then 5223 goto Next_E; 5224 5225 elsif Is_Type (E1) then 5226 5227 -- Subtypes must statically match. E1, E2 are the local entities 5228 -- that are subtypes of the actuals. Itypes generated for other 5229 -- parameters need not be checked, the check will be performed 5230 -- on the parameters themselves. 5231 5232 -- If E2 is a formal type declaration, it is a defaulted parameter 5233 -- and needs no checking. 5234 5235 if not Is_Itype (E1) 5236 and then not Is_Itype (E2) 5237 then 5238 Check_Mismatch 5239 (not Is_Type (E2) 5240 or else Etype (E1) /= Etype (E2) 5241 or else not Subtypes_Statically_Match (E1, E2)); 5242 end if; 5243 5244 elsif Ekind (E1) = E_Constant then 5245 5246 -- IN parameters must denote the same static value, or the same 5247 -- constant, or the literal null. 5248 5249 Expr1 := Expression (Parent (E1)); 5250 5251 if Ekind (E2) /= E_Constant then 5252 Check_Mismatch (True); 5253 goto Next_E; 5254 else 5255 Expr2 := Expression (Parent (E2)); 5256 end if; 5257 5258 if Is_Static_Expression (Expr1) then 5259 5260 if not Is_Static_Expression (Expr2) then 5261 Check_Mismatch (True); 5262 5263 elsif Is_Discrete_Type (Etype (E1)) then 5264 declare 5265 V1 : constant Uint := Expr_Value (Expr1); 5266 V2 : constant Uint := Expr_Value (Expr2); 5267 begin 5268 Check_Mismatch (V1 /= V2); 5269 end; 5270 5271 elsif Is_Real_Type (Etype (E1)) then 5272 declare 5273 V1 : constant Ureal := Expr_Value_R (Expr1); 5274 V2 : constant Ureal := Expr_Value_R (Expr2); 5275 begin 5276 Check_Mismatch (V1 /= V2); 5277 end; 5278 5279 elsif Is_String_Type (Etype (E1)) 5280 and then Nkind (Expr1) = N_String_Literal 5281 then 5282 if Nkind (Expr2) /= N_String_Literal then 5283 Check_Mismatch (True); 5284 else 5285 Check_Mismatch 5286 (not String_Equal (Strval (Expr1), Strval (Expr2))); 5287 end if; 5288 end if; 5289 5290 elsif Is_Entity_Name (Expr1) then 5291 if Is_Entity_Name (Expr2) then 5292 if Entity (Expr1) = Entity (Expr2) then 5293 null; 5294 else 5295 Check_Mismatch 5296 (not Same_Instantiated_Constant 5297 (Entity (Expr1), Entity (Expr2))); 5298 end if; 5299 else 5300 Check_Mismatch (True); 5301 end if; 5302 5303 elsif Is_Entity_Name (Original_Node (Expr1)) 5304 and then Is_Entity_Name (Expr2) 5305 and then 5306 Same_Instantiated_Constant 5307 (Entity (Original_Node (Expr1)), Entity (Expr2)) 5308 then 5309 null; 5310 5311 elsif Nkind (Expr1) = N_Null then 5312 Check_Mismatch (Nkind (Expr1) /= N_Null); 5313 5314 else 5315 Check_Mismatch (True); 5316 end if; 5317 5318 elsif Ekind (E1) = E_Variable then 5319 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 5320 5321 elsif Ekind (E1) = E_Package then 5322 Check_Mismatch 5323 (Ekind (E1) /= Ekind (E2) 5324 or else Renamed_Object (E1) /= Renamed_Object (E2)); 5325 5326 elsif Is_Overloadable (E1) then 5327 5328 -- Verify that the actual subprograms match. Note that actuals 5329 -- that are attributes are rewritten as subprograms. If the 5330 -- subprogram in the formal package is defaulted, no check is 5331 -- needed. Note that this can only happen in Ada 2005 when the 5332 -- formal package can be partially parameterized. 5333 5334 if Nkind (Unit_Declaration_Node (E1)) = 5335 N_Subprogram_Renaming_Declaration 5336 and then From_Default (Unit_Declaration_Node (E1)) 5337 then 5338 null; 5339 5340 -- If the formal package has an "others" box association that 5341 -- covers this formal, there is no need for a check either. 5342 5343 elsif Nkind (Unit_Declaration_Node (E2)) in 5344 N_Formal_Subprogram_Declaration 5345 and then Box_Present (Unit_Declaration_Node (E2)) 5346 then 5347 null; 5348 5349 -- No check needed if subprogram is a defaulted null procedure 5350 5351 elsif No (Alias (E2)) 5352 and then Ekind (E2) = E_Procedure 5353 and then 5354 Null_Present (Specification (Unit_Declaration_Node (E2))) 5355 then 5356 null; 5357 5358 -- Otherwise the actual in the formal and the actual in the 5359 -- instantiation of the formal must match, up to renamings. 5360 5361 else 5362 Check_Mismatch 5363 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); 5364 end if; 5365 5366 else 5367 raise Program_Error; 5368 end if; 5369 5370 <<Next_E>> 5371 Next_Entity (E1); 5372 Next_Entity (E2); 5373 end loop; 5374 end Check_Formal_Package_Instance; 5375 5376 --------------------------- 5377 -- Check_Formal_Packages -- 5378 --------------------------- 5379 5380 procedure Check_Formal_Packages (P_Id : Entity_Id) is 5381 E : Entity_Id; 5382 Formal_P : Entity_Id; 5383 5384 begin 5385 -- Iterate through the declarations in the instance, looking for package 5386 -- renaming declarations that denote instances of formal packages. Stop 5387 -- when we find the renaming of the current package itself. The 5388 -- declaration for a formal package without a box is followed by an 5389 -- internal entity that repeats the instantiation. 5390 5391 E := First_Entity (P_Id); 5392 while Present (E) loop 5393 if Ekind (E) = E_Package then 5394 if Renamed_Object (E) = P_Id then 5395 exit; 5396 5397 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 5398 null; 5399 5400 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then 5401 Formal_P := Next_Entity (E); 5402 Check_Formal_Package_Instance (Formal_P, E); 5403 5404 -- After checking, remove the internal validating package. It 5405 -- is only needed for semantic checks, and as it may contain 5406 -- generic formal declarations it should not reach gigi. 5407 5408 Remove (Unit_Declaration_Node (Formal_P)); 5409 end if; 5410 end if; 5411 5412 Next_Entity (E); 5413 end loop; 5414 end Check_Formal_Packages; 5415 5416 --------------------------------- 5417 -- Check_Forward_Instantiation -- 5418 --------------------------------- 5419 5420 procedure Check_Forward_Instantiation (Decl : Node_Id) is 5421 S : Entity_Id; 5422 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 5423 5424 begin 5425 -- The instantiation appears before the generic body if we are in the 5426 -- scope of the unit containing the generic, either in its spec or in 5427 -- the package body, and before the generic body. 5428 5429 if Ekind (Gen_Comp) = E_Package_Body then 5430 Gen_Comp := Spec_Entity (Gen_Comp); 5431 end if; 5432 5433 if In_Open_Scopes (Gen_Comp) 5434 and then No (Corresponding_Body (Decl)) 5435 then 5436 S := Current_Scope; 5437 5438 while Present (S) 5439 and then not Is_Compilation_Unit (S) 5440 and then not Is_Child_Unit (S) 5441 loop 5442 if Ekind (S) = E_Package then 5443 Set_Has_Forward_Instantiation (S); 5444 end if; 5445 5446 S := Scope (S); 5447 end loop; 5448 end if; 5449 end Check_Forward_Instantiation; 5450 5451 --------------------------- 5452 -- Check_Generic_Actuals -- 5453 --------------------------- 5454 5455 -- The visibility of the actuals may be different between the point of 5456 -- generic instantiation and the instantiation of the body. 5457 5458 procedure Check_Generic_Actuals 5459 (Instance : Entity_Id; 5460 Is_Formal_Box : Boolean) 5461 is 5462 E : Entity_Id; 5463 Astype : Entity_Id; 5464 5465 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 5466 -- For a formal that is an array type, the component type is often a 5467 -- previous formal in the same unit. The privacy status of the component 5468 -- type will have been examined earlier in the traversal of the 5469 -- corresponding actuals, and this status should not be modified for the 5470 -- array type itself. 5471 -- 5472 -- To detect this case we have to rescan the list of formals, which 5473 -- is usually short enough to ignore the resulting inefficiency. 5474 5475 ----------------------------- 5476 -- Denotes_Previous_Actual -- 5477 ----------------------------- 5478 5479 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 5480 Prev : Entity_Id; 5481 5482 begin 5483 Prev := First_Entity (Instance); 5484 while Present (Prev) loop 5485 if Is_Type (Prev) 5486 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 5487 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 5488 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 5489 then 5490 return True; 5491 5492 elsif Prev = E then 5493 return False; 5494 5495 else 5496 Next_Entity (Prev); 5497 end if; 5498 end loop; 5499 5500 return False; 5501 end Denotes_Previous_Actual; 5502 5503 -- Start of processing for Check_Generic_Actuals 5504 5505 begin 5506 E := First_Entity (Instance); 5507 while Present (E) loop 5508 if Is_Type (E) 5509 and then Nkind (Parent (E)) = N_Subtype_Declaration 5510 and then Scope (Etype (E)) /= Instance 5511 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 5512 then 5513 if Is_Array_Type (E) 5514 and then Denotes_Previous_Actual (Component_Type (E)) 5515 then 5516 null; 5517 else 5518 Check_Private_View (Subtype_Indication (Parent (E))); 5519 end if; 5520 5521 Set_Is_Generic_Actual_Type (E, True); 5522 Set_Is_Hidden (E, False); 5523 Set_Is_Potentially_Use_Visible (E, 5524 In_Use (Instance)); 5525 5526 -- We constructed the generic actual type as a subtype of the 5527 -- supplied type. This means that it normally would not inherit 5528 -- subtype specific attributes of the actual, which is wrong for 5529 -- the generic case. 5530 5531 Astype := Ancestor_Subtype (E); 5532 5533 if No (Astype) then 5534 5535 -- This can happen when E is an itype that is the full view of 5536 -- a private type completed, e.g. with a constrained array. In 5537 -- that case, use the first subtype, which will carry size 5538 -- information. The base type itself is unconstrained and will 5539 -- not carry it. 5540 5541 Astype := First_Subtype (E); 5542 end if; 5543 5544 Set_Size_Info (E, (Astype)); 5545 Set_RM_Size (E, RM_Size (Astype)); 5546 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 5547 5548 if Is_Discrete_Or_Fixed_Point_Type (E) then 5549 Set_RM_Size (E, RM_Size (Astype)); 5550 5551 -- In nested instances, the base type of an access actual 5552 -- may itself be private, and need to be exchanged. 5553 5554 elsif Is_Access_Type (E) 5555 and then Is_Private_Type (Etype (E)) 5556 then 5557 Check_Private_View 5558 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 5559 end if; 5560 5561 elsif Ekind (E) = E_Package then 5562 5563 -- If this is the renaming for the current instance, we're done. 5564 -- Otherwise it is a formal package. If the corresponding formal 5565 -- was declared with a box, the (instantiations of the) generic 5566 -- formal part are also visible. Otherwise, ignore the entity 5567 -- created to validate the actuals. 5568 5569 if Renamed_Object (E) = Instance then 5570 exit; 5571 5572 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 5573 null; 5574 5575 -- The visibility of a formal of an enclosing generic is already 5576 -- correct. 5577 5578 elsif Denotes_Formal_Package (E) then 5579 null; 5580 5581 elsif Present (Associated_Formal_Package (E)) 5582 and then not Is_Generic_Formal (E) 5583 then 5584 if Box_Present (Parent (Associated_Formal_Package (E))) then 5585 Check_Generic_Actuals (Renamed_Object (E), True); 5586 5587 else 5588 Check_Generic_Actuals (Renamed_Object (E), False); 5589 end if; 5590 5591 Set_Is_Hidden (E, False); 5592 end if; 5593 5594 -- If this is a subprogram instance (in a wrapper package) the 5595 -- actual is fully visible. 5596 5597 elsif Is_Wrapper_Package (Instance) then 5598 Set_Is_Hidden (E, False); 5599 5600 -- If the formal package is declared with a box, or if the formal 5601 -- parameter is defaulted, it is visible in the body. 5602 5603 elsif Is_Formal_Box 5604 or else Is_Visible_Formal (E) 5605 then 5606 Set_Is_Hidden (E, False); 5607 end if; 5608 5609 if Ekind (E) = E_Constant then 5610 5611 -- If the type of the actual is a private type declared in the 5612 -- enclosing scope of the generic unit, the body of the generic 5613 -- sees the full view of the type (because it has to appear in 5614 -- the corresponding package body). If the type is private now, 5615 -- exchange views to restore the proper visiblity in the instance. 5616 5617 declare 5618 Typ : constant Entity_Id := Base_Type (Etype (E)); 5619 -- The type of the actual 5620 5621 Gen_Id : Entity_Id; 5622 -- The generic unit 5623 5624 Parent_Scope : Entity_Id; 5625 -- The enclosing scope of the generic unit 5626 5627 begin 5628 if Is_Wrapper_Package (Instance) then 5629 Gen_Id := 5630 Generic_Parent 5631 (Specification 5632 (Unit_Declaration_Node 5633 (Related_Instance (Instance)))); 5634 else 5635 Gen_Id := 5636 Generic_Parent 5637 (Specification (Unit_Declaration_Node (Instance))); 5638 end if; 5639 5640 Parent_Scope := Scope (Gen_Id); 5641 5642 -- The exchange is only needed if the generic is defined 5643 -- within a package which is not a common ancestor of the 5644 -- scope of the instance, and is not already in scope. 5645 5646 if Is_Private_Type (Typ) 5647 and then Scope (Typ) = Parent_Scope 5648 and then Scope (Instance) /= Parent_Scope 5649 and then Ekind (Parent_Scope) = E_Package 5650 and then not Is_Child_Unit (Gen_Id) 5651 then 5652 Switch_View (Typ); 5653 5654 -- If the type of the entity is a subtype, it may also 5655 -- have to be made visible, together with the base type 5656 -- of its full view, after exchange. 5657 5658 if Is_Private_Type (Etype (E)) then 5659 Switch_View (Etype (E)); 5660 Switch_View (Base_Type (Etype (E))); 5661 end if; 5662 end if; 5663 end; 5664 end if; 5665 5666 Next_Entity (E); 5667 end loop; 5668 end Check_Generic_Actuals; 5669 5670 ------------------------------ 5671 -- Check_Generic_Child_Unit -- 5672 ------------------------------ 5673 5674 procedure Check_Generic_Child_Unit 5675 (Gen_Id : Node_Id; 5676 Parent_Installed : in out Boolean) 5677 is 5678 Loc : constant Source_Ptr := Sloc (Gen_Id); 5679 Gen_Par : Entity_Id := Empty; 5680 E : Entity_Id; 5681 Inst_Par : Entity_Id; 5682 S : Node_Id; 5683 5684 function Find_Generic_Child 5685 (Scop : Entity_Id; 5686 Id : Node_Id) return Entity_Id; 5687 -- Search generic parent for possible child unit with the given name 5688 5689 function In_Enclosing_Instance return Boolean; 5690 -- Within an instance of the parent, the child unit may be denoted 5691 -- by a simple name, or an abbreviated expanded name. Examine enclosing 5692 -- scopes to locate a possible parent instantiation. 5693 5694 ------------------------ 5695 -- Find_Generic_Child -- 5696 ------------------------ 5697 5698 function Find_Generic_Child 5699 (Scop : Entity_Id; 5700 Id : Node_Id) return Entity_Id 5701 is 5702 E : Entity_Id; 5703 5704 begin 5705 -- If entity of name is already set, instance has already been 5706 -- resolved, e.g. in an enclosing instantiation. 5707 5708 if Present (Entity (Id)) then 5709 if Scope (Entity (Id)) = Scop then 5710 return Entity (Id); 5711 else 5712 return Empty; 5713 end if; 5714 5715 else 5716 E := First_Entity (Scop); 5717 while Present (E) loop 5718 if Chars (E) = Chars (Id) 5719 and then Is_Child_Unit (E) 5720 then 5721 if Is_Child_Unit (E) 5722 and then not Is_Visible_Lib_Unit (E) 5723 then 5724 Error_Msg_NE 5725 ("generic child unit& is not visible", Gen_Id, E); 5726 end if; 5727 5728 Set_Entity (Id, E); 5729 return E; 5730 end if; 5731 5732 Next_Entity (E); 5733 end loop; 5734 5735 return Empty; 5736 end if; 5737 end Find_Generic_Child; 5738 5739 --------------------------- 5740 -- In_Enclosing_Instance -- 5741 --------------------------- 5742 5743 function In_Enclosing_Instance return Boolean is 5744 Enclosing_Instance : Node_Id; 5745 Instance_Decl : Node_Id; 5746 5747 begin 5748 -- We do not inline any call that contains instantiations, except 5749 -- for instantiations of Unchecked_Conversion, so if we are within 5750 -- an inlined body the current instance does not require parents. 5751 5752 if In_Inlined_Body then 5753 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 5754 return False; 5755 end if; 5756 5757 -- Loop to check enclosing scopes 5758 5759 Enclosing_Instance := Current_Scope; 5760 while Present (Enclosing_Instance) loop 5761 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 5762 5763 if Ekind (Enclosing_Instance) = E_Package 5764 and then Is_Generic_Instance (Enclosing_Instance) 5765 and then Present 5766 (Generic_Parent (Specification (Instance_Decl))) 5767 then 5768 -- Check whether the generic we are looking for is a child of 5769 -- this instance. 5770 5771 E := Find_Generic_Child 5772 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 5773 exit when Present (E); 5774 5775 else 5776 E := Empty; 5777 end if; 5778 5779 Enclosing_Instance := Scope (Enclosing_Instance); 5780 end loop; 5781 5782 if No (E) then 5783 5784 -- Not a child unit 5785 5786 Analyze (Gen_Id); 5787 return False; 5788 5789 else 5790 Rewrite (Gen_Id, 5791 Make_Expanded_Name (Loc, 5792 Chars => Chars (E), 5793 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 5794 Selector_Name => New_Occurrence_Of (E, Loc))); 5795 5796 Set_Entity (Gen_Id, E); 5797 Set_Etype (Gen_Id, Etype (E)); 5798 Parent_Installed := False; -- Already in scope. 5799 return True; 5800 end if; 5801 end In_Enclosing_Instance; 5802 5803 -- Start of processing for Check_Generic_Child_Unit 5804 5805 begin 5806 -- If the name of the generic is given by a selected component, it may 5807 -- be the name of a generic child unit, and the prefix is the name of an 5808 -- instance of the parent, in which case the child unit must be visible. 5809 -- If this instance is not in scope, it must be placed there and removed 5810 -- after instantiation, because what is being instantiated is not the 5811 -- original child, but the corresponding child present in the instance 5812 -- of the parent. 5813 5814 -- If the child is instantiated within the parent, it can be given by 5815 -- a simple name. In this case the instance is already in scope, but 5816 -- the child generic must be recovered from the generic parent as well. 5817 5818 if Nkind (Gen_Id) = N_Selected_Component then 5819 S := Selector_Name (Gen_Id); 5820 Analyze (Prefix (Gen_Id)); 5821 Inst_Par := Entity (Prefix (Gen_Id)); 5822 5823 if Ekind (Inst_Par) = E_Package 5824 and then Present (Renamed_Object (Inst_Par)) 5825 then 5826 Inst_Par := Renamed_Object (Inst_Par); 5827 end if; 5828 5829 if Ekind (Inst_Par) = E_Package then 5830 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 5831 Gen_Par := Generic_Parent (Parent (Inst_Par)); 5832 5833 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 5834 and then 5835 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 5836 then 5837 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 5838 end if; 5839 5840 elsif Ekind (Inst_Par) = E_Generic_Package 5841 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 5842 then 5843 -- A formal package may be a real child package, and not the 5844 -- implicit instance within a parent. In this case the child is 5845 -- not visible and has to be retrieved explicitly as well. 5846 5847 Gen_Par := Inst_Par; 5848 end if; 5849 5850 if Present (Gen_Par) then 5851 5852 -- The prefix denotes an instantiation. The entity itself may be a 5853 -- nested generic, or a child unit. 5854 5855 E := Find_Generic_Child (Gen_Par, S); 5856 5857 if Present (E) then 5858 Change_Selected_Component_To_Expanded_Name (Gen_Id); 5859 Set_Entity (Gen_Id, E); 5860 Set_Etype (Gen_Id, Etype (E)); 5861 Set_Entity (S, E); 5862 Set_Etype (S, Etype (E)); 5863 5864 -- Indicate that this is a reference to the parent 5865 5866 if In_Extended_Main_Source_Unit (Gen_Id) then 5867 Set_Is_Instantiated (Inst_Par); 5868 end if; 5869 5870 -- A common mistake is to replicate the naming scheme of a 5871 -- hierarchy by instantiating a generic child directly, rather 5872 -- than the implicit child in a parent instance: 5873 5874 -- generic .. package Gpar is .. 5875 -- generic .. package Gpar.Child is .. 5876 -- package Par is new Gpar (); 5877 5878 -- with Gpar.Child; 5879 -- package Par.Child is new Gpar.Child (); 5880 -- rather than Par.Child 5881 5882 -- In this case the instantiation is within Par, which is an 5883 -- instance, but Gpar does not denote Par because we are not IN 5884 -- the instance of Gpar, so this is illegal. The test below 5885 -- recognizes this particular case. 5886 5887 if Is_Child_Unit (E) 5888 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 5889 and then (not In_Instance 5890 or else Nkind (Parent (Parent (Gen_Id))) = 5891 N_Compilation_Unit) 5892 then 5893 Error_Msg_N 5894 ("prefix of generic child unit must be instance of parent", 5895 Gen_Id); 5896 end if; 5897 5898 if not In_Open_Scopes (Inst_Par) 5899 and then Nkind (Parent (Gen_Id)) not in 5900 N_Generic_Renaming_Declaration 5901 then 5902 Install_Parent (Inst_Par); 5903 Parent_Installed := True; 5904 5905 elsif In_Open_Scopes (Inst_Par) then 5906 5907 -- If the parent is already installed, install the actuals 5908 -- for its formal packages. This is necessary when the 5909 -- child instance is a child of the parent instance: 5910 -- in this case, the parent is placed on the scope stack 5911 -- but the formal packages are not made visible. 5912 5913 Install_Formal_Packages (Inst_Par); 5914 end if; 5915 5916 else 5917 -- If the generic parent does not contain an entity that 5918 -- corresponds to the selector, the instance doesn't either. 5919 -- Analyzing the node will yield the appropriate error message. 5920 -- If the entity is not a child unit, then it is an inner 5921 -- generic in the parent. 5922 5923 Analyze (Gen_Id); 5924 end if; 5925 5926 else 5927 Analyze (Gen_Id); 5928 5929 if Is_Child_Unit (Entity (Gen_Id)) 5930 and then 5931 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 5932 and then not In_Open_Scopes (Inst_Par) 5933 then 5934 Install_Parent (Inst_Par); 5935 Parent_Installed := True; 5936 5937 -- The generic unit may be the renaming of the implicit child 5938 -- present in an instance. In that case the parent instance is 5939 -- obtained from the name of the renamed entity. 5940 5941 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 5942 and then Present (Renamed_Entity (Entity (Gen_Id))) 5943 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 5944 then 5945 declare 5946 Renamed_Package : constant Node_Id := 5947 Name (Parent (Entity (Gen_Id))); 5948 begin 5949 if Nkind (Renamed_Package) = N_Expanded_Name then 5950 Inst_Par := Entity (Prefix (Renamed_Package)); 5951 Install_Parent (Inst_Par); 5952 Parent_Installed := True; 5953 end if; 5954 end; 5955 end if; 5956 end if; 5957 5958 elsif Nkind (Gen_Id) = N_Expanded_Name then 5959 5960 -- Entity already present, analyze prefix, whose meaning may be 5961 -- an instance in the current context. If it is an instance of 5962 -- a relative within another, the proper parent may still have 5963 -- to be installed, if they are not of the same generation. 5964 5965 Analyze (Prefix (Gen_Id)); 5966 5967 -- In the unlikely case that a local declaration hides the name 5968 -- of the parent package, locate it on the homonym chain. If the 5969 -- context is an instance of the parent, the renaming entity is 5970 -- flagged as such. 5971 5972 Inst_Par := Entity (Prefix (Gen_Id)); 5973 while Present (Inst_Par) 5974 and then not Is_Package_Or_Generic_Package (Inst_Par) 5975 loop 5976 Inst_Par := Homonym (Inst_Par); 5977 end loop; 5978 5979 pragma Assert (Present (Inst_Par)); 5980 Set_Entity (Prefix (Gen_Id), Inst_Par); 5981 5982 if In_Enclosing_Instance then 5983 null; 5984 5985 elsif Present (Entity (Gen_Id)) 5986 and then Is_Child_Unit (Entity (Gen_Id)) 5987 and then not In_Open_Scopes (Inst_Par) 5988 then 5989 Install_Parent (Inst_Par); 5990 Parent_Installed := True; 5991 end if; 5992 5993 elsif In_Enclosing_Instance then 5994 5995 -- The child unit is found in some enclosing scope 5996 5997 null; 5998 5999 else 6000 Analyze (Gen_Id); 6001 6002 -- If this is the renaming of the implicit child in a parent 6003 -- instance, recover the parent name and install it. 6004 6005 if Is_Entity_Name (Gen_Id) then 6006 E := Entity (Gen_Id); 6007 6008 if Is_Generic_Unit (E) 6009 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 6010 and then Is_Child_Unit (Renamed_Object (E)) 6011 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 6012 and then Nkind (Name (Parent (E))) = N_Expanded_Name 6013 then 6014 Rewrite (Gen_Id, 6015 New_Copy_Tree (Name (Parent (E)))); 6016 Inst_Par := Entity (Prefix (Gen_Id)); 6017 6018 if not In_Open_Scopes (Inst_Par) then 6019 Install_Parent (Inst_Par); 6020 Parent_Installed := True; 6021 end if; 6022 6023 -- If it is a child unit of a non-generic parent, it may be 6024 -- use-visible and given by a direct name. Install parent as 6025 -- for other cases. 6026 6027 elsif Is_Generic_Unit (E) 6028 and then Is_Child_Unit (E) 6029 and then 6030 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 6031 and then not Is_Generic_Unit (Scope (E)) 6032 then 6033 if not In_Open_Scopes (Scope (E)) then 6034 Install_Parent (Scope (E)); 6035 Parent_Installed := True; 6036 end if; 6037 end if; 6038 end if; 6039 end if; 6040 end Check_Generic_Child_Unit; 6041 6042 ----------------------------- 6043 -- Check_Hidden_Child_Unit -- 6044 ----------------------------- 6045 6046 procedure Check_Hidden_Child_Unit 6047 (N : Node_Id; 6048 Gen_Unit : Entity_Id; 6049 Act_Decl_Id : Entity_Id) 6050 is 6051 Gen_Id : constant Node_Id := Name (N); 6052 6053 begin 6054 if Is_Child_Unit (Gen_Unit) 6055 and then Is_Child_Unit (Act_Decl_Id) 6056 and then Nkind (Gen_Id) = N_Expanded_Name 6057 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 6058 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 6059 then 6060 Error_Msg_Node_2 := Scope (Act_Decl_Id); 6061 Error_Msg_NE 6062 ("generic unit & is implicitly declared in &", 6063 Defining_Unit_Name (N), Gen_Unit); 6064 Error_Msg_N ("\instance must have different name", 6065 Defining_Unit_Name (N)); 6066 end if; 6067 end Check_Hidden_Child_Unit; 6068 6069 ------------------------ 6070 -- Check_Private_View -- 6071 ------------------------ 6072 6073 procedure Check_Private_View (N : Node_Id) is 6074 T : constant Entity_Id := Etype (N); 6075 BT : Entity_Id; 6076 6077 begin 6078 -- Exchange views if the type was not private in the generic but is 6079 -- private at the point of instantiation. Do not exchange views if 6080 -- the scope of the type is in scope. This can happen if both generic 6081 -- and instance are sibling units, or if type is defined in a parent. 6082 -- In this case the visibility of the type will be correct for all 6083 -- semantic checks. 6084 6085 if Present (T) then 6086 BT := Base_Type (T); 6087 6088 if Is_Private_Type (T) 6089 and then not Has_Private_View (N) 6090 and then Present (Full_View (T)) 6091 and then not In_Open_Scopes (Scope (T)) 6092 then 6093 -- In the generic, the full type was visible. Save the private 6094 -- entity, for subsequent exchange. 6095 6096 Switch_View (T); 6097 6098 elsif Has_Private_View (N) 6099 and then not Is_Private_Type (T) 6100 and then not Has_Been_Exchanged (T) 6101 and then Etype (Get_Associated_Node (N)) /= T 6102 then 6103 -- Only the private declaration was visible in the generic. If 6104 -- the type appears in a subtype declaration, the subtype in the 6105 -- instance must have a view compatible with that of its parent, 6106 -- which must be exchanged (see corresponding code in Restore_ 6107 -- Private_Views). Otherwise, if the type is defined in a parent 6108 -- unit, leave full visibility within instance, which is safe. 6109 6110 if In_Open_Scopes (Scope (Base_Type (T))) 6111 and then not Is_Private_Type (Base_Type (T)) 6112 and then Comes_From_Source (Base_Type (T)) 6113 then 6114 null; 6115 6116 elsif Nkind (Parent (N)) = N_Subtype_Declaration 6117 or else not In_Private_Part (Scope (Base_Type (T))) 6118 then 6119 Prepend_Elmt (T, Exchanged_Views); 6120 Exchange_Declarations (Etype (Get_Associated_Node (N))); 6121 end if; 6122 6123 -- For composite types with inconsistent representation exchange 6124 -- component types accordingly. 6125 6126 elsif Is_Access_Type (T) 6127 and then Is_Private_Type (Designated_Type (T)) 6128 and then not Has_Private_View (N) 6129 and then Present (Full_View (Designated_Type (T))) 6130 then 6131 Switch_View (Designated_Type (T)); 6132 6133 elsif Is_Array_Type (T) then 6134 if Is_Private_Type (Component_Type (T)) 6135 and then not Has_Private_View (N) 6136 and then Present (Full_View (Component_Type (T))) 6137 then 6138 Switch_View (Component_Type (T)); 6139 end if; 6140 6141 -- The normal exchange mechanism relies on the setting of a 6142 -- flag on the reference in the generic. However, an additional 6143 -- mechanism is needed for types that are not explicitly mentioned 6144 -- in the generic, but may be needed in expanded code in the 6145 -- instance. This includes component types of arrays and 6146 -- designated types of access types. This processing must also 6147 -- include the index types of arrays which we take care of here. 6148 6149 declare 6150 Indx : Node_Id; 6151 Typ : Entity_Id; 6152 6153 begin 6154 Indx := First_Index (T); 6155 while Present (Indx) loop 6156 Typ := Base_Type (Etype (Indx)); 6157 6158 if Is_Private_Type (Typ) 6159 and then Present (Full_View (Typ)) 6160 then 6161 Switch_View (Typ); 6162 end if; 6163 6164 Next_Index (Indx); 6165 end loop; 6166 end; 6167 6168 elsif Is_Private_Type (T) 6169 and then Present (Full_View (T)) 6170 and then Is_Array_Type (Full_View (T)) 6171 and then Is_Private_Type (Component_Type (Full_View (T))) 6172 then 6173 Switch_View (T); 6174 6175 -- Finally, a non-private subtype may have a private base type, which 6176 -- must be exchanged for consistency. This can happen when a package 6177 -- body is instantiated, when the scope stack is empty but in fact 6178 -- the subtype and the base type are declared in an enclosing scope. 6179 6180 -- Note that in this case we introduce an inconsistency in the view 6181 -- set, because we switch the base type BT, but there could be some 6182 -- private dependent subtypes of BT which remain unswitched. Such 6183 -- subtypes might need to be switched at a later point (see specific 6184 -- provision for that case in Switch_View). 6185 6186 elsif not Is_Private_Type (T) 6187 and then not Has_Private_View (N) 6188 and then Is_Private_Type (BT) 6189 and then Present (Full_View (BT)) 6190 and then not Is_Generic_Type (BT) 6191 and then not In_Open_Scopes (BT) 6192 then 6193 Prepend_Elmt (Full_View (BT), Exchanged_Views); 6194 Exchange_Declarations (BT); 6195 end if; 6196 end if; 6197 end Check_Private_View; 6198 6199 ----------------------------- 6200 -- Check_Hidden_Primitives -- 6201 ----------------------------- 6202 6203 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 6204 Actual : Node_Id; 6205 Gen_T : Entity_Id; 6206 Result : Elist_Id := No_Elist; 6207 6208 begin 6209 if No (Assoc_List) then 6210 return No_Elist; 6211 end if; 6212 6213 -- Traverse the list of associations between formals and actuals 6214 -- searching for renamings of tagged types 6215 6216 Actual := First (Assoc_List); 6217 while Present (Actual) loop 6218 if Nkind (Actual) = N_Subtype_Declaration then 6219 Gen_T := Generic_Parent_Type (Actual); 6220 6221 if Present (Gen_T) 6222 and then Is_Tagged_Type (Gen_T) 6223 then 6224 -- Traverse the list of primitives of the actual types 6225 -- searching for hidden primitives that are visible in the 6226 -- corresponding generic formal; leave them visible and 6227 -- append them to Result to restore their decoration later. 6228 6229 Install_Hidden_Primitives 6230 (Prims_List => Result, 6231 Gen_T => Gen_T, 6232 Act_T => Entity (Subtype_Indication (Actual))); 6233 end if; 6234 end if; 6235 6236 Next (Actual); 6237 end loop; 6238 6239 return Result; 6240 end Check_Hidden_Primitives; 6241 6242 -------------------------- 6243 -- Contains_Instance_Of -- 6244 -------------------------- 6245 6246 function Contains_Instance_Of 6247 (Inner : Entity_Id; 6248 Outer : Entity_Id; 6249 N : Node_Id) return Boolean 6250 is 6251 Elmt : Elmt_Id; 6252 Scop : Entity_Id; 6253 6254 begin 6255 Scop := Outer; 6256 6257 -- Verify that there are no circular instantiations. We check whether 6258 -- the unit contains an instance of the current scope or some enclosing 6259 -- scope (in case one of the instances appears in a subunit). Longer 6260 -- circularities involving subunits might seem too pathological to 6261 -- consider, but they were not too pathological for the authors of 6262 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 6263 -- enclosing generic scopes as containing an instance. 6264 6265 loop 6266 -- Within a generic subprogram body, the scope is not generic, to 6267 -- allow for recursive subprograms. Use the declaration to determine 6268 -- whether this is a generic unit. 6269 6270 if Ekind (Scop) = E_Generic_Package 6271 or else (Is_Subprogram (Scop) 6272 and then Nkind (Unit_Declaration_Node (Scop)) = 6273 N_Generic_Subprogram_Declaration) 6274 then 6275 Elmt := First_Elmt (Inner_Instances (Inner)); 6276 6277 while Present (Elmt) loop 6278 if Node (Elmt) = Scop then 6279 Error_Msg_Node_2 := Inner; 6280 Error_Msg_NE 6281 ("circular Instantiation: & instantiated within &!", 6282 N, Scop); 6283 return True; 6284 6285 elsif Node (Elmt) = Inner then 6286 return True; 6287 6288 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 6289 Error_Msg_Node_2 := Inner; 6290 Error_Msg_NE 6291 ("circular Instantiation: & instantiated within &!", 6292 N, Node (Elmt)); 6293 return True; 6294 end if; 6295 6296 Next_Elmt (Elmt); 6297 end loop; 6298 6299 -- Indicate that Inner is being instantiated within Scop 6300 6301 Append_Elmt (Inner, Inner_Instances (Scop)); 6302 end if; 6303 6304 if Scop = Standard_Standard then 6305 exit; 6306 else 6307 Scop := Scope (Scop); 6308 end if; 6309 end loop; 6310 6311 return False; 6312 end Contains_Instance_Of; 6313 6314 ----------------------- 6315 -- Copy_Generic_Node -- 6316 ----------------------- 6317 6318 function Copy_Generic_Node 6319 (N : Node_Id; 6320 Parent_Id : Node_Id; 6321 Instantiating : Boolean) return Node_Id 6322 is 6323 Ent : Entity_Id; 6324 New_N : Node_Id; 6325 6326 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 6327 -- Check the given value of one of the Fields referenced by the 6328 -- current node to determine whether to copy it recursively. The 6329 -- field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain 6330 -- value (Sloc, Uint, Char) in which case it need not be copied. 6331 6332 procedure Copy_Descendants; 6333 -- Common utility for various nodes 6334 6335 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 6336 -- Make copy of element list 6337 6338 function Copy_Generic_List 6339 (L : List_Id; 6340 Parent_Id : Node_Id) return List_Id; 6341 -- Apply Copy_Node recursively to the members of a node list 6342 6343 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 6344 -- True if an identifier is part of the defining program unit name 6345 -- of a child unit. The entity of such an identifier must be kept 6346 -- (for ASIS use) even though as the name of an enclosing generic 6347 -- it would otherwise not be preserved in the generic tree. 6348 6349 ---------------------- 6350 -- Copy_Descendants -- 6351 ---------------------- 6352 6353 procedure Copy_Descendants is 6354 6355 use Atree.Unchecked_Access; 6356 -- This code section is part of the implementation of an untyped 6357 -- tree traversal, so it needs direct access to node fields. 6358 6359 begin 6360 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 6361 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 6362 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 6363 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 6364 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 6365 end Copy_Descendants; 6366 6367 ----------------------------- 6368 -- Copy_Generic_Descendant -- 6369 ----------------------------- 6370 6371 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 6372 begin 6373 if D = Union_Id (Empty) then 6374 return D; 6375 6376 elsif D in Node_Range then 6377 return Union_Id 6378 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 6379 6380 elsif D in List_Range then 6381 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 6382 6383 elsif D in Elist_Range then 6384 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 6385 6386 -- Nothing else is copyable (e.g. Uint values), return as is 6387 6388 else 6389 return D; 6390 end if; 6391 end Copy_Generic_Descendant; 6392 6393 ------------------------ 6394 -- Copy_Generic_Elist -- 6395 ------------------------ 6396 6397 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 6398 M : Elmt_Id; 6399 L : Elist_Id; 6400 6401 begin 6402 if Present (E) then 6403 L := New_Elmt_List; 6404 M := First_Elmt (E); 6405 while Present (M) loop 6406 Append_Elmt 6407 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 6408 Next_Elmt (M); 6409 end loop; 6410 6411 return L; 6412 6413 else 6414 return No_Elist; 6415 end if; 6416 end Copy_Generic_Elist; 6417 6418 ----------------------- 6419 -- Copy_Generic_List -- 6420 ----------------------- 6421 6422 function Copy_Generic_List 6423 (L : List_Id; 6424 Parent_Id : Node_Id) return List_Id 6425 is 6426 N : Node_Id; 6427 New_L : List_Id; 6428 6429 begin 6430 if Present (L) then 6431 New_L := New_List; 6432 Set_Parent (New_L, Parent_Id); 6433 6434 N := First (L); 6435 while Present (N) loop 6436 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 6437 Next (N); 6438 end loop; 6439 6440 return New_L; 6441 6442 else 6443 return No_List; 6444 end if; 6445 end Copy_Generic_List; 6446 6447 --------------------------- 6448 -- In_Defining_Unit_Name -- 6449 --------------------------- 6450 6451 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 6452 begin 6453 return Present (Parent (Nam)) 6454 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 6455 or else 6456 (Nkind (Parent (Nam)) = N_Expanded_Name 6457 and then In_Defining_Unit_Name (Parent (Nam)))); 6458 end In_Defining_Unit_Name; 6459 6460 -- Start of processing for Copy_Generic_Node 6461 6462 begin 6463 if N = Empty then 6464 return N; 6465 end if; 6466 6467 New_N := New_Copy (N); 6468 6469 -- Copy aspects if present 6470 6471 if Has_Aspects (N) then 6472 Set_Has_Aspects (New_N, False); 6473 Set_Aspect_Specifications 6474 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 6475 end if; 6476 6477 if Instantiating then 6478 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 6479 end if; 6480 6481 if not Is_List_Member (N) then 6482 Set_Parent (New_N, Parent_Id); 6483 end if; 6484 6485 -- If defining identifier, then all fields have been copied already 6486 6487 if Nkind (New_N) in N_Entity then 6488 null; 6489 6490 -- Special casing for identifiers and other entity names and operators 6491 6492 elsif Nkind_In (New_N, N_Identifier, 6493 N_Character_Literal, 6494 N_Expanded_Name, 6495 N_Operator_Symbol) 6496 or else Nkind (New_N) in N_Op 6497 then 6498 if not Instantiating then 6499 6500 -- Link both nodes in order to assign subsequently the entity of 6501 -- the copy to the original node, in case this is a global 6502 -- reference. 6503 6504 Set_Associated_Node (N, New_N); 6505 6506 -- If we are within an instantiation, this is a nested generic 6507 -- that has already been analyzed at the point of definition. We 6508 -- must preserve references that were global to the enclosing 6509 -- parent at that point. Other occurrences, whether global or 6510 -- local to the current generic, must be resolved anew, so we 6511 -- reset the entity in the generic copy. A global reference has a 6512 -- smaller depth than the parent, or else the same depth in case 6513 -- both are distinct compilation units. 6514 -- A child unit is implicitly declared within the enclosing parent 6515 -- but is in fact global to it, and must be preserved. 6516 6517 -- It is also possible for Current_Instantiated_Parent to be 6518 -- defined, and for this not to be a nested generic, namely if the 6519 -- unit is loaded through Rtsfind. In that case, the entity of 6520 -- New_N is only a link to the associated node, and not a defining 6521 -- occurrence. 6522 6523 -- The entities for parent units in the defining_program_unit of a 6524 -- generic child unit are established when the context of the unit 6525 -- is first analyzed, before the generic copy is made. They are 6526 -- preserved in the copy for use in ASIS queries. 6527 6528 Ent := Entity (New_N); 6529 6530 if No (Current_Instantiated_Parent.Gen_Id) then 6531 if No (Ent) 6532 or else Nkind (Ent) /= N_Defining_Identifier 6533 or else not In_Defining_Unit_Name (N) 6534 then 6535 Set_Associated_Node (New_N, Empty); 6536 end if; 6537 6538 elsif No (Ent) 6539 or else 6540 not Nkind_In (Ent, N_Defining_Identifier, 6541 N_Defining_Character_Literal, 6542 N_Defining_Operator_Symbol) 6543 or else No (Scope (Ent)) 6544 or else 6545 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 6546 and then not Is_Child_Unit (Ent)) 6547 or else 6548 (Scope_Depth (Scope (Ent)) > 6549 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 6550 and then 6551 Get_Source_Unit (Ent) = 6552 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 6553 then 6554 Set_Associated_Node (New_N, Empty); 6555 end if; 6556 6557 -- Case of instantiating identifier or some other name or operator 6558 6559 else 6560 -- If the associated node is still defined, the entity in it is 6561 -- global, and must be copied to the instance. If this copy is 6562 -- being made for a body to inline, it is applied to an 6563 -- instantiated tree, and the entity is already present and must 6564 -- be also preserved. 6565 6566 declare 6567 Assoc : constant Node_Id := Get_Associated_Node (N); 6568 6569 begin 6570 if Present (Assoc) then 6571 if Nkind (Assoc) = Nkind (N) then 6572 Set_Entity (New_N, Entity (Assoc)); 6573 Check_Private_View (N); 6574 6575 elsif Nkind (Assoc) = N_Function_Call then 6576 Set_Entity (New_N, Entity (Name (Assoc))); 6577 6578 elsif Nkind_In (Assoc, N_Defining_Identifier, 6579 N_Defining_Character_Literal, 6580 N_Defining_Operator_Symbol) 6581 and then Expander_Active 6582 then 6583 -- Inlining case: we are copying a tree that contains 6584 -- global entities, which are preserved in the copy to be 6585 -- used for subsequent inlining. 6586 6587 null; 6588 6589 else 6590 Set_Entity (New_N, Empty); 6591 end if; 6592 end if; 6593 end; 6594 end if; 6595 6596 -- For expanded name, we must copy the Prefix and Selector_Name 6597 6598 if Nkind (N) = N_Expanded_Name then 6599 Set_Prefix 6600 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 6601 6602 Set_Selector_Name (New_N, 6603 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 6604 6605 -- For operators, we must copy the right operand 6606 6607 elsif Nkind (N) in N_Op then 6608 Set_Right_Opnd (New_N, 6609 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 6610 6611 -- And for binary operators, the left operand as well 6612 6613 if Nkind (N) in N_Binary_Op then 6614 Set_Left_Opnd (New_N, 6615 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 6616 end if; 6617 end if; 6618 6619 -- Special casing for stubs 6620 6621 elsif Nkind (N) in N_Body_Stub then 6622 6623 -- In any case, we must copy the specification or defining 6624 -- identifier as appropriate. 6625 6626 if Nkind (N) = N_Subprogram_Body_Stub then 6627 Set_Specification (New_N, 6628 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 6629 6630 else 6631 Set_Defining_Identifier (New_N, 6632 Copy_Generic_Node 6633 (Defining_Identifier (N), New_N, Instantiating)); 6634 end if; 6635 6636 -- If we are not instantiating, then this is where we load and 6637 -- analyze subunits, i.e. at the point where the stub occurs. A 6638 -- more permissive system might defer this analysis to the point 6639 -- of instantiation, but this seems to complicated for now. 6640 6641 if not Instantiating then 6642 declare 6643 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 6644 Subunit : Node_Id; 6645 Unum : Unit_Number_Type; 6646 New_Body : Node_Id; 6647 6648 begin 6649 -- Make sure that, if it is a subunit of the main unit that is 6650 -- preprocessed and if -gnateG is specified, the preprocessed 6651 -- file will be written. 6652 6653 Lib.Analysing_Subunit_Of_Main := 6654 Lib.In_Extended_Main_Source_Unit (N); 6655 Unum := 6656 Load_Unit 6657 (Load_Name => Subunit_Name, 6658 Required => False, 6659 Subunit => True, 6660 Error_Node => N); 6661 Lib.Analysing_Subunit_Of_Main := False; 6662 6663 -- If the proper body is not found, a warning message will be 6664 -- emitted when analyzing the stub, or later at the point 6665 -- of instantiation. Here we just leave the stub as is. 6666 6667 if Unum = No_Unit then 6668 Subunits_Missing := True; 6669 goto Subunit_Not_Found; 6670 end if; 6671 6672 Subunit := Cunit (Unum); 6673 6674 if Nkind (Unit (Subunit)) /= N_Subunit then 6675 Error_Msg_N 6676 ("found child unit instead of expected SEPARATE subunit", 6677 Subunit); 6678 Error_Msg_Sloc := Sloc (N); 6679 Error_Msg_N ("\to complete stub #", Subunit); 6680 goto Subunit_Not_Found; 6681 end if; 6682 6683 -- We must create a generic copy of the subunit, in order to 6684 -- perform semantic analysis on it, and we must replace the 6685 -- stub in the original generic unit with the subunit, in order 6686 -- to preserve non-local references within. 6687 6688 -- Only the proper body needs to be copied. Library_Unit and 6689 -- context clause are simply inherited by the generic copy. 6690 -- Note that the copy (which may be recursive if there are 6691 -- nested subunits) must be done first, before attaching it to 6692 -- the enclosing generic. 6693 6694 New_Body := 6695 Copy_Generic_Node 6696 (Proper_Body (Unit (Subunit)), 6697 Empty, Instantiating => False); 6698 6699 -- Now place the original proper body in the original generic 6700 -- unit. This is a body, not a compilation unit. 6701 6702 Rewrite (N, Proper_Body (Unit (Subunit))); 6703 Set_Is_Compilation_Unit (Defining_Entity (N), False); 6704 Set_Was_Originally_Stub (N); 6705 6706 -- Finally replace the body of the subunit with its copy, and 6707 -- make this new subunit into the library unit of the generic 6708 -- copy, which does not have stubs any longer. 6709 6710 Set_Proper_Body (Unit (Subunit), New_Body); 6711 Set_Library_Unit (New_N, Subunit); 6712 Inherit_Context (Unit (Subunit), N); 6713 end; 6714 6715 -- If we are instantiating, this must be an error case, since 6716 -- otherwise we would have replaced the stub node by the proper body 6717 -- that corresponds. So just ignore it in the copy (i.e. we have 6718 -- copied it, and that is good enough). 6719 6720 else 6721 null; 6722 end if; 6723 6724 <<Subunit_Not_Found>> null; 6725 6726 -- If the node is a compilation unit, it is the subunit of a stub, which 6727 -- has been loaded already (see code below). In this case, the library 6728 -- unit field of N points to the parent unit (which is a compilation 6729 -- unit) and need not (and cannot!) be copied. 6730 6731 -- When the proper body of the stub is analyzed, the library_unit link 6732 -- is used to establish the proper context (see sem_ch10). 6733 6734 -- The other fields of a compilation unit are copied as usual 6735 6736 elsif Nkind (N) = N_Compilation_Unit then 6737 6738 -- This code can only be executed when not instantiating, because in 6739 -- the copy made for an instantiation, the compilation unit node has 6740 -- disappeared at the point that a stub is replaced by its proper 6741 -- body. 6742 6743 pragma Assert (not Instantiating); 6744 6745 Set_Context_Items (New_N, 6746 Copy_Generic_List (Context_Items (N), New_N)); 6747 6748 Set_Unit (New_N, 6749 Copy_Generic_Node (Unit (N), New_N, False)); 6750 6751 Set_First_Inlined_Subprogram (New_N, 6752 Copy_Generic_Node 6753 (First_Inlined_Subprogram (N), New_N, False)); 6754 6755 Set_Aux_Decls_Node (New_N, 6756 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False)); 6757 6758 -- For an assignment node, the assignment is known to be semantically 6759 -- legal if we are instantiating the template. This avoids incorrect 6760 -- diagnostics in generated code. 6761 6762 elsif Nkind (N) = N_Assignment_Statement then 6763 6764 -- Copy name and expression fields in usual manner 6765 6766 Set_Name (New_N, 6767 Copy_Generic_Node (Name (N), New_N, Instantiating)); 6768 6769 Set_Expression (New_N, 6770 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 6771 6772 if Instantiating then 6773 Set_Assignment_OK (Name (New_N), True); 6774 end if; 6775 6776 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 6777 if not Instantiating then 6778 Set_Associated_Node (N, New_N); 6779 6780 else 6781 if Present (Get_Associated_Node (N)) 6782 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 6783 then 6784 -- In the generic the aggregate has some composite type. If at 6785 -- the point of instantiation the type has a private view, 6786 -- install the full view (and that of its ancestors, if any). 6787 6788 declare 6789 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 6790 Rt : Entity_Id; 6791 6792 begin 6793 if Present (T) 6794 and then Is_Private_Type (T) 6795 then 6796 Switch_View (T); 6797 end if; 6798 6799 if Present (T) 6800 and then Is_Tagged_Type (T) 6801 and then Is_Derived_Type (T) 6802 then 6803 Rt := Root_Type (T); 6804 6805 loop 6806 T := Etype (T); 6807 6808 if Is_Private_Type (T) then 6809 Switch_View (T); 6810 end if; 6811 6812 exit when T = Rt; 6813 end loop; 6814 end if; 6815 end; 6816 end if; 6817 end if; 6818 6819 -- Do not copy the associated node, which points to the generic copy 6820 -- of the aggregate. 6821 6822 declare 6823 use Atree.Unchecked_Access; 6824 -- This code section is part of the implementation of an untyped 6825 -- tree traversal, so it needs direct access to node fields. 6826 6827 begin 6828 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 6829 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 6830 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 6831 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 6832 end; 6833 6834 -- Allocators do not have an identifier denoting the access type, so we 6835 -- must locate it through the expression to check whether the views are 6836 -- consistent. 6837 6838 elsif Nkind (N) = N_Allocator 6839 and then Nkind (Expression (N)) = N_Qualified_Expression 6840 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 6841 and then Instantiating 6842 then 6843 declare 6844 T : constant Node_Id := 6845 Get_Associated_Node (Subtype_Mark (Expression (N))); 6846 Acc_T : Entity_Id; 6847 6848 begin 6849 if Present (T) then 6850 6851 -- Retrieve the allocator node in the generic copy 6852 6853 Acc_T := Etype (Parent (Parent (T))); 6854 if Present (Acc_T) 6855 and then Is_Private_Type (Acc_T) 6856 then 6857 Switch_View (Acc_T); 6858 end if; 6859 end if; 6860 6861 Copy_Descendants; 6862 end; 6863 6864 -- For a proper body, we must catch the case of a proper body that 6865 -- replaces a stub. This represents the point at which a separate 6866 -- compilation unit, and hence template file, may be referenced, so we 6867 -- must make a new source instantiation entry for the template of the 6868 -- subunit, and ensure that all nodes in the subunit are adjusted using 6869 -- this new source instantiation entry. 6870 6871 elsif Nkind (N) in N_Proper_Body then 6872 declare 6873 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 6874 6875 begin 6876 if Instantiating and then Was_Originally_Stub (N) then 6877 Create_Instantiation_Source 6878 (Instantiation_Node, 6879 Defining_Entity (N), 6880 False, 6881 S_Adjustment); 6882 end if; 6883 6884 -- Now copy the fields of the proper body, using the new 6885 -- adjustment factor if one was needed as per test above. 6886 6887 Copy_Descendants; 6888 6889 -- Restore the original adjustment factor in case changed 6890 6891 S_Adjustment := Save_Adjustment; 6892 end; 6893 6894 -- Don't copy Ident or Comment pragmas, since the comment belongs to the 6895 -- generic unit, not to the instantiating unit. 6896 6897 elsif Nkind (N) = N_Pragma and then Instantiating then 6898 declare 6899 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); 6900 begin 6901 if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then 6902 New_N := Make_Null_Statement (Sloc (N)); 6903 6904 else 6905 Copy_Descendants; 6906 end if; 6907 end; 6908 6909 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 6910 6911 -- No descendant fields need traversing 6912 6913 null; 6914 6915 elsif Nkind (N) = N_String_Literal 6916 and then Present (Etype (N)) 6917 and then Instantiating 6918 then 6919 -- If the string is declared in an outer scope, the string_literal 6920 -- subtype created for it may have the wrong scope. We force the 6921 -- reanalysis of the constant to generate a new itype in the proper 6922 -- context. 6923 6924 Set_Etype (New_N, Empty); 6925 Set_Analyzed (New_N, False); 6926 6927 -- For the remaining nodes, copy their descendants recursively 6928 6929 else 6930 Copy_Descendants; 6931 6932 if Instantiating and then Nkind (N) = N_Subprogram_Body then 6933 Set_Generic_Parent (Specification (New_N), N); 6934 6935 -- Should preserve Corresponding_Spec??? (12.3(14)) 6936 end if; 6937 end if; 6938 6939 return New_N; 6940 end Copy_Generic_Node; 6941 6942 ---------------------------- 6943 -- Denotes_Formal_Package -- 6944 ---------------------------- 6945 6946 function Denotes_Formal_Package 6947 (Pack : Entity_Id; 6948 On_Exit : Boolean := False; 6949 Instance : Entity_Id := Empty) return Boolean 6950 is 6951 Par : Entity_Id; 6952 Scop : constant Entity_Id := Scope (Pack); 6953 E : Entity_Id; 6954 6955 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 6956 -- The package in question may be an actual for a previous formal 6957 -- package P of the current instance, so examine its actuals as well. 6958 -- This must be recursive over other formal packages. 6959 6960 ---------------------------------- 6961 -- Is_Actual_Of_Previous_Formal -- 6962 ---------------------------------- 6963 6964 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 6965 E1 : Entity_Id; 6966 6967 begin 6968 E1 := First_Entity (P); 6969 while Present (E1) and then E1 /= Instance loop 6970 if Ekind (E1) = E_Package 6971 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 6972 then 6973 if Renamed_Object (E1) = Pack then 6974 return True; 6975 6976 elsif E1 = P or else Renamed_Object (E1) = P then 6977 return False; 6978 6979 elsif Is_Actual_Of_Previous_Formal (E1) then 6980 return True; 6981 end if; 6982 end if; 6983 6984 Next_Entity (E1); 6985 end loop; 6986 6987 return False; 6988 end Is_Actual_Of_Previous_Formal; 6989 6990 -- Start of processing for Denotes_Formal_Package 6991 6992 begin 6993 if On_Exit then 6994 Par := 6995 Instance_Envs.Table 6996 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 6997 else 6998 Par := Current_Instantiated_Parent.Act_Id; 6999 end if; 7000 7001 if Ekind (Scop) = E_Generic_Package 7002 or else Nkind (Unit_Declaration_Node (Scop)) = 7003 N_Generic_Subprogram_Declaration 7004 then 7005 return True; 7006 7007 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 7008 N_Formal_Package_Declaration 7009 then 7010 return True; 7011 7012 elsif No (Par) then 7013 return False; 7014 7015 else 7016 -- Check whether this package is associated with a formal package of 7017 -- the enclosing instantiation. Iterate over the list of renamings. 7018 7019 E := First_Entity (Par); 7020 while Present (E) loop 7021 if Ekind (E) /= E_Package 7022 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 7023 then 7024 null; 7025 7026 elsif Renamed_Object (E) = Par then 7027 return False; 7028 7029 elsif Renamed_Object (E) = Pack then 7030 return True; 7031 7032 elsif Is_Actual_Of_Previous_Formal (E) then 7033 return True; 7034 7035 end if; 7036 7037 Next_Entity (E); 7038 end loop; 7039 7040 return False; 7041 end if; 7042 end Denotes_Formal_Package; 7043 7044 ----------------- 7045 -- End_Generic -- 7046 ----------------- 7047 7048 procedure End_Generic is 7049 begin 7050 -- ??? More things could be factored out in this routine. Should 7051 -- probably be done at a later stage. 7052 7053 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 7054 Generic_Flags.Decrement_Last; 7055 7056 Expander_Mode_Restore; 7057 end End_Generic; 7058 7059 ------------- 7060 -- Earlier -- 7061 ------------- 7062 7063 function Earlier (N1, N2 : Node_Id) return Boolean is 7064 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 7065 -- Find distance from given node to enclosing compilation unit 7066 7067 ---------------- 7068 -- Find_Depth -- 7069 ---------------- 7070 7071 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 7072 begin 7073 while Present (P) 7074 and then Nkind (P) /= N_Compilation_Unit 7075 loop 7076 P := True_Parent (P); 7077 D := D + 1; 7078 end loop; 7079 end Find_Depth; 7080 7081 -- Local declarations 7082 7083 D1 : Integer := 0; 7084 D2 : Integer := 0; 7085 P1 : Node_Id := N1; 7086 P2 : Node_Id := N2; 7087 T1 : Source_Ptr; 7088 T2 : Source_Ptr; 7089 7090 -- Start of processing for Earlier 7091 7092 begin 7093 Find_Depth (P1, D1); 7094 Find_Depth (P2, D2); 7095 7096 if P1 /= P2 then 7097 return False; 7098 else 7099 P1 := N1; 7100 P2 := N2; 7101 end if; 7102 7103 while D1 > D2 loop 7104 P1 := True_Parent (P1); 7105 D1 := D1 - 1; 7106 end loop; 7107 7108 while D2 > D1 loop 7109 P2 := True_Parent (P2); 7110 D2 := D2 - 1; 7111 end loop; 7112 7113 -- At this point P1 and P2 are at the same distance from the root. 7114 -- We examine their parents until we find a common declarative list. 7115 -- If we reach the root, N1 and N2 do not descend from the same 7116 -- declarative list (e.g. one is nested in the declarative part and 7117 -- the other is in a block in the statement part) and the earlier 7118 -- one is already frozen. 7119 7120 while not Is_List_Member (P1) 7121 or else not Is_List_Member (P2) 7122 or else List_Containing (P1) /= List_Containing (P2) 7123 loop 7124 P1 := True_Parent (P1); 7125 P2 := True_Parent (P2); 7126 7127 if Nkind (Parent (P1)) = N_Subunit then 7128 P1 := Corresponding_Stub (Parent (P1)); 7129 end if; 7130 7131 if Nkind (Parent (P2)) = N_Subunit then 7132 P2 := Corresponding_Stub (Parent (P2)); 7133 end if; 7134 7135 if P1 = P2 then 7136 return False; 7137 end if; 7138 end loop; 7139 7140 -- Expanded code usually shares the source location of the original 7141 -- construct it was generated for. This however may not necessarely 7142 -- reflect the true location of the code within the tree. 7143 7144 -- Before comparing the slocs of the two nodes, make sure that we are 7145 -- working with correct source locations. Assume that P1 is to the left 7146 -- of P2. If either one does not come from source, traverse the common 7147 -- list heading towards the other node and locate the first source 7148 -- statement. 7149 7150 -- P1 P2 7151 -- ----+===+===+--------------+===+===+---- 7152 -- expanded code expanded code 7153 7154 if not Comes_From_Source (P1) then 7155 while Present (P1) loop 7156 7157 -- Neither P2 nor a source statement were located during the 7158 -- search. If we reach the end of the list, then P1 does not 7159 -- occur earlier than P2. 7160 7161 -- ----> 7162 -- start --- P2 ----- P1 --- end 7163 7164 if No (Next (P1)) then 7165 return False; 7166 7167 -- We encounter P2 while going to the right of the list. This 7168 -- means that P1 does indeed appear earlier. 7169 7170 -- ----> 7171 -- start --- P1 ===== P2 --- end 7172 -- expanded code in between 7173 7174 elsif P1 = P2 then 7175 return True; 7176 7177 -- No need to look any further since we have located a source 7178 -- statement. 7179 7180 elsif Comes_From_Source (P1) then 7181 exit; 7182 end if; 7183 7184 -- Keep going right 7185 7186 Next (P1); 7187 end loop; 7188 end if; 7189 7190 if not Comes_From_Source (P2) then 7191 while Present (P2) loop 7192 7193 -- Neither P1 nor a source statement were located during the 7194 -- search. If we reach the start of the list, then P1 does not 7195 -- occur earlier than P2. 7196 7197 -- <---- 7198 -- start --- P2 --- P1 --- end 7199 7200 if No (Prev (P2)) then 7201 return False; 7202 7203 -- We encounter P1 while going to the left of the list. This 7204 -- means that P1 does indeed appear earlier. 7205 7206 -- <---- 7207 -- start --- P1 ===== P2 --- end 7208 -- expanded code in between 7209 7210 elsif P2 = P1 then 7211 return True; 7212 7213 -- No need to look any further since we have located a source 7214 -- statement. 7215 7216 elsif Comes_From_Source (P2) then 7217 exit; 7218 end if; 7219 7220 -- Keep going left 7221 7222 Prev (P2); 7223 end loop; 7224 end if; 7225 7226 -- At this point either both nodes came from source or we approximated 7227 -- their source locations through neighbouring source statements. 7228 7229 T1 := Top_Level_Location (Sloc (P1)); 7230 T2 := Top_Level_Location (Sloc (P2)); 7231 7232 -- When two nodes come from the same instance, they have identical top 7233 -- level locations. To determine proper relation within the tree, check 7234 -- their locations within the template. 7235 7236 if T1 = T2 then 7237 return Sloc (P1) < Sloc (P2); 7238 7239 -- The two nodes either come from unrelated instances or do not come 7240 -- from instantiated code at all. 7241 7242 else 7243 return T1 < T2; 7244 end if; 7245 end Earlier; 7246 7247 ---------------------- 7248 -- Find_Actual_Type -- 7249 ---------------------- 7250 7251 function Find_Actual_Type 7252 (Typ : Entity_Id; 7253 Gen_Type : Entity_Id) return Entity_Id 7254 is 7255 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 7256 T : Entity_Id; 7257 7258 begin 7259 -- Special processing only applies to child units 7260 7261 if not Is_Child_Unit (Gen_Scope) then 7262 return Get_Instance_Of (Typ); 7263 7264 -- If designated or component type is itself a formal of the child unit, 7265 -- its instance is available. 7266 7267 elsif Scope (Typ) = Gen_Scope then 7268 return Get_Instance_Of (Typ); 7269 7270 -- If the array or access type is not declared in the parent unit, 7271 -- no special processing needed. 7272 7273 elsif not Is_Generic_Type (Typ) 7274 and then Scope (Gen_Scope) /= Scope (Typ) 7275 then 7276 return Get_Instance_Of (Typ); 7277 7278 -- Otherwise, retrieve designated or component type by visibility 7279 7280 else 7281 T := Current_Entity (Typ); 7282 while Present (T) loop 7283 if In_Open_Scopes (Scope (T)) then 7284 return T; 7285 7286 elsif Is_Generic_Actual_Type (T) then 7287 return T; 7288 end if; 7289 7290 T := Homonym (T); 7291 end loop; 7292 7293 return Typ; 7294 end if; 7295 end Find_Actual_Type; 7296 7297 ---------------------------- 7298 -- Freeze_Subprogram_Body -- 7299 ---------------------------- 7300 7301 procedure Freeze_Subprogram_Body 7302 (Inst_Node : Node_Id; 7303 Gen_Body : Node_Id; 7304 Pack_Id : Entity_Id) 7305 is 7306 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 7307 Par : constant Entity_Id := Scope (Gen_Unit); 7308 E_G_Id : Entity_Id; 7309 Enc_G : Entity_Id; 7310 Enc_I : Node_Id; 7311 F_Node : Node_Id; 7312 7313 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 7314 -- Find innermost package body that encloses the given node, and which 7315 -- is not a compilation unit. Freeze nodes for the instance, or for its 7316 -- enclosing body, may be inserted after the enclosing_body of the 7317 -- generic unit. Used to determine proper placement of freeze node for 7318 -- both package and subprogram instances. 7319 7320 function Package_Freeze_Node (B : Node_Id) return Node_Id; 7321 -- Find entity for given package body, and locate or create a freeze 7322 -- node for it. 7323 7324 ---------------------------- 7325 -- Enclosing_Package_Body -- 7326 ---------------------------- 7327 7328 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 7329 P : Node_Id; 7330 7331 begin 7332 P := Parent (N); 7333 while Present (P) 7334 and then Nkind (Parent (P)) /= N_Compilation_Unit 7335 loop 7336 if Nkind (P) = N_Package_Body then 7337 if Nkind (Parent (P)) = N_Subunit then 7338 return Corresponding_Stub (Parent (P)); 7339 else 7340 return P; 7341 end if; 7342 end if; 7343 7344 P := True_Parent (P); 7345 end loop; 7346 7347 return Empty; 7348 end Enclosing_Package_Body; 7349 7350 ------------------------- 7351 -- Package_Freeze_Node -- 7352 ------------------------- 7353 7354 function Package_Freeze_Node (B : Node_Id) return Node_Id is 7355 Id : Entity_Id; 7356 7357 begin 7358 if Nkind (B) = N_Package_Body then 7359 Id := Corresponding_Spec (B); 7360 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 7361 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 7362 end if; 7363 7364 Ensure_Freeze_Node (Id); 7365 return Freeze_Node (Id); 7366 end Package_Freeze_Node; 7367 7368 -- Start of processing of Freeze_Subprogram_Body 7369 7370 begin 7371 -- If the instance and the generic body appear within the same unit, and 7372 -- the instance precedes the generic, the freeze node for the instance 7373 -- must appear after that of the generic. If the generic is nested 7374 -- within another instance I2, then current instance must be frozen 7375 -- after I2. In both cases, the freeze nodes are those of enclosing 7376 -- packages. Otherwise, the freeze node is placed at the end of the 7377 -- current declarative part. 7378 7379 Enc_G := Enclosing_Package_Body (Gen_Body); 7380 Enc_I := Enclosing_Package_Body (Inst_Node); 7381 Ensure_Freeze_Node (Pack_Id); 7382 F_Node := Freeze_Node (Pack_Id); 7383 7384 if Is_Generic_Instance (Par) 7385 and then Present (Freeze_Node (Par)) 7386 and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) 7387 then 7388 -- The parent was a premature instantiation. Insert freeze node at 7389 -- the end the current declarative part. 7390 7391 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then 7392 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7393 7394 -- Handle the following case: 7395 -- 7396 -- package Parent_Inst is new ... 7397 -- Parent_Inst [] 7398 -- 7399 -- procedure P ... -- this body freezes Parent_Inst 7400 -- 7401 -- package Inst is new ... 7402 -- 7403 -- In this particular scenario, the freeze node for Inst must be 7404 -- inserted in the same manner as that of Parent_Inst - before the 7405 -- next source body or at the end of the declarative list (body not 7406 -- available). If body P did not exist and Parent_Inst was frozen 7407 -- after Inst, either by a body following Inst or at the end of the 7408 -- declarative region, the freeze node for Inst must be inserted 7409 -- after that of Parent_Inst. This relation is established by 7410 -- comparing the Slocs of Parent_Inst freeze node and Inst. 7411 7412 elsif List_Containing (Get_Package_Instantiation_Node (Par)) = 7413 List_Containing (Inst_Node) 7414 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 7415 then 7416 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7417 7418 else 7419 Insert_After (Freeze_Node (Par), F_Node); 7420 end if; 7421 7422 -- The body enclosing the instance should be frozen after the body that 7423 -- includes the generic, because the body of the instance may make 7424 -- references to entities therein. If the two are not in the same 7425 -- declarative part, or if the one enclosing the instance is frozen 7426 -- already, freeze the instance at the end of the current declarative 7427 -- part. 7428 7429 elsif Is_Generic_Instance (Par) 7430 and then Present (Freeze_Node (Par)) 7431 and then Present (Enc_I) 7432 then 7433 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) 7434 or else 7435 (Nkind (Enc_I) = N_Package_Body 7436 and then 7437 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) 7438 then 7439 -- The enclosing package may contain several instances. Rather 7440 -- than computing the earliest point at which to insert its freeze 7441 -- node, we place it at the end of the declarative part of the 7442 -- parent of the generic. 7443 7444 Insert_Freeze_Node_For_Instance 7445 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 7446 end if; 7447 7448 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7449 7450 elsif Present (Enc_G) 7451 and then Present (Enc_I) 7452 and then Enc_G /= Enc_I 7453 and then Earlier (Inst_Node, Gen_Body) 7454 then 7455 if Nkind (Enc_G) = N_Package_Body then 7456 E_G_Id := Corresponding_Spec (Enc_G); 7457 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 7458 E_G_Id := 7459 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 7460 end if; 7461 7462 -- Freeze package that encloses instance, and place node after 7463 -- package that encloses generic. If enclosing package is already 7464 -- frozen we have to assume it is at the proper place. This may be a 7465 -- potential ABE that requires dynamic checking. Do not add a freeze 7466 -- node if the package that encloses the generic is inside the body 7467 -- that encloses the instance, because the freeze node would be in 7468 -- the wrong scope. Additional contortions needed if the bodies are 7469 -- within a subunit. 7470 7471 declare 7472 Enclosing_Body : Node_Id; 7473 7474 begin 7475 if Nkind (Enc_I) = N_Package_Body_Stub then 7476 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 7477 else 7478 Enclosing_Body := Enc_I; 7479 end if; 7480 7481 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 7482 Insert_Freeze_Node_For_Instance 7483 (Enc_G, Package_Freeze_Node (Enc_I)); 7484 end if; 7485 end; 7486 7487 -- Freeze enclosing subunit before instance 7488 7489 Ensure_Freeze_Node (E_G_Id); 7490 7491 if not Is_List_Member (Freeze_Node (E_G_Id)) then 7492 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 7493 end if; 7494 7495 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7496 7497 else 7498 -- If none of the above, insert freeze node at the end of the current 7499 -- declarative part. 7500 7501 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7502 end if; 7503 end Freeze_Subprogram_Body; 7504 7505 ---------------- 7506 -- Get_Gen_Id -- 7507 ---------------- 7508 7509 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 7510 begin 7511 return Generic_Renamings.Table (E).Gen_Id; 7512 end Get_Gen_Id; 7513 7514 --------------------- 7515 -- Get_Instance_Of -- 7516 --------------------- 7517 7518 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 7519 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 7520 7521 begin 7522 if Res /= Assoc_Null then 7523 return Generic_Renamings.Table (Res).Act_Id; 7524 else 7525 -- On exit, entity is not instantiated: not a generic parameter, or 7526 -- else parameter of an inner generic unit. 7527 7528 return A; 7529 end if; 7530 end Get_Instance_Of; 7531 7532 ------------------------------------ 7533 -- Get_Package_Instantiation_Node -- 7534 ------------------------------------ 7535 7536 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is 7537 Decl : Node_Id := Unit_Declaration_Node (A); 7538 Inst : Node_Id; 7539 7540 begin 7541 -- If the Package_Instantiation attribute has been set on the package 7542 -- entity, then use it directly when it (or its Original_Node) refers 7543 -- to an N_Package_Instantiation node. In principle it should be 7544 -- possible to have this field set in all cases, which should be 7545 -- investigated, and would allow this function to be significantly 7546 -- simplified. ??? 7547 7548 Inst := Package_Instantiation (A); 7549 7550 if Present (Inst) then 7551 if Nkind (Inst) = N_Package_Instantiation then 7552 return Inst; 7553 7554 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 7555 return Original_Node (Inst); 7556 end if; 7557 end if; 7558 7559 -- If the instantiation is a compilation unit that does not need body 7560 -- then the instantiation node has been rewritten as a package 7561 -- declaration for the instance, and we return the original node. 7562 7563 -- If it is a compilation unit and the instance node has not been 7564 -- rewritten, then it is still the unit of the compilation. Finally, if 7565 -- a body is present, this is a parent of the main unit whose body has 7566 -- been compiled for inlining purposes, and the instantiation node has 7567 -- been rewritten with the instance body. 7568 7569 -- Otherwise the instantiation node appears after the declaration. If 7570 -- the entity is a formal package, the declaration may have been 7571 -- rewritten as a generic declaration (in the case of a formal with box) 7572 -- or left as a formal package declaration if it has actuals, and is 7573 -- found with a forward search. 7574 7575 if Nkind (Parent (Decl)) = N_Compilation_Unit then 7576 if Nkind (Decl) = N_Package_Declaration 7577 and then Present (Corresponding_Body (Decl)) 7578 then 7579 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 7580 end if; 7581 7582 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then 7583 return Original_Node (Decl); 7584 else 7585 return Unit (Parent (Decl)); 7586 end if; 7587 7588 elsif Nkind (Decl) = N_Package_Declaration 7589 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 7590 then 7591 return Original_Node (Decl); 7592 7593 else 7594 Inst := Next (Decl); 7595 while not Nkind_In (Inst, N_Package_Instantiation, 7596 N_Formal_Package_Declaration) 7597 loop 7598 Next (Inst); 7599 end loop; 7600 7601 return Inst; 7602 end if; 7603 end Get_Package_Instantiation_Node; 7604 7605 ------------------------ 7606 -- Has_Been_Exchanged -- 7607 ------------------------ 7608 7609 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 7610 Next : Elmt_Id; 7611 7612 begin 7613 Next := First_Elmt (Exchanged_Views); 7614 while Present (Next) loop 7615 if Full_View (Node (Next)) = E then 7616 return True; 7617 end if; 7618 7619 Next_Elmt (Next); 7620 end loop; 7621 7622 return False; 7623 end Has_Been_Exchanged; 7624 7625 ---------- 7626 -- Hash -- 7627 ---------- 7628 7629 function Hash (F : Entity_Id) return HTable_Range is 7630 begin 7631 return HTable_Range (F mod HTable_Size); 7632 end Hash; 7633 7634 ------------------------ 7635 -- Hide_Current_Scope -- 7636 ------------------------ 7637 7638 procedure Hide_Current_Scope is 7639 C : constant Entity_Id := Current_Scope; 7640 E : Entity_Id; 7641 7642 begin 7643 Set_Is_Hidden_Open_Scope (C); 7644 7645 E := First_Entity (C); 7646 while Present (E) loop 7647 if Is_Immediately_Visible (E) then 7648 Set_Is_Immediately_Visible (E, False); 7649 Append_Elmt (E, Hidden_Entities); 7650 end if; 7651 7652 Next_Entity (E); 7653 end loop; 7654 7655 -- Make the scope name invisible as well. This is necessary, but might 7656 -- conflict with calls to Rtsfind later on, in case the scope is a 7657 -- predefined one. There is no clean solution to this problem, so for 7658 -- now we depend on the user not redefining Standard itself in one of 7659 -- the parent units. 7660 7661 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 7662 Set_Is_Immediately_Visible (C, False); 7663 Append_Elmt (C, Hidden_Entities); 7664 end if; 7665 7666 end Hide_Current_Scope; 7667 7668 -------------- 7669 -- Init_Env -- 7670 -------------- 7671 7672 procedure Init_Env is 7673 Saved : Instance_Env; 7674 7675 begin 7676 Saved.Instantiated_Parent := Current_Instantiated_Parent; 7677 Saved.Exchanged_Views := Exchanged_Views; 7678 Saved.Hidden_Entities := Hidden_Entities; 7679 Saved.Current_Sem_Unit := Current_Sem_Unit; 7680 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 7681 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 7682 7683 -- Save configuration switches. These may be reset if the unit is a 7684 -- predefined unit, and the current mode is not Ada 2005. 7685 7686 Save_Opt_Config_Switches (Saved.Switches); 7687 7688 Instance_Envs.Append (Saved); 7689 7690 Exchanged_Views := New_Elmt_List; 7691 Hidden_Entities := New_Elmt_List; 7692 7693 -- Make dummy entry for Instantiated parent. If generic unit is legal, 7694 -- this is set properly in Set_Instance_Env. 7695 7696 Current_Instantiated_Parent := 7697 (Current_Scope, Current_Scope, Assoc_Null); 7698 end Init_Env; 7699 7700 ------------------------------ 7701 -- In_Same_Declarative_Part -- 7702 ------------------------------ 7703 7704 function In_Same_Declarative_Part 7705 (F_Node : Node_Id; 7706 Inst : Node_Id) return Boolean 7707 is 7708 Decls : constant Node_Id := Parent (F_Node); 7709 Nod : Node_Id := Parent (Inst); 7710 7711 begin 7712 while Present (Nod) loop 7713 if Nod = Decls then 7714 return True; 7715 7716 elsif Nkind_In (Nod, N_Subprogram_Body, 7717 N_Package_Body, 7718 N_Package_Declaration, 7719 N_Task_Body, 7720 N_Protected_Body, 7721 N_Block_Statement) 7722 then 7723 return False; 7724 7725 elsif Nkind (Nod) = N_Subunit then 7726 Nod := Corresponding_Stub (Nod); 7727 7728 elsif Nkind (Nod) = N_Compilation_Unit then 7729 return False; 7730 7731 else 7732 Nod := Parent (Nod); 7733 end if; 7734 end loop; 7735 7736 return False; 7737 end In_Same_Declarative_Part; 7738 7739 --------------------- 7740 -- In_Main_Context -- 7741 --------------------- 7742 7743 function In_Main_Context (E : Entity_Id) return Boolean is 7744 Context : List_Id; 7745 Clause : Node_Id; 7746 Nam : Node_Id; 7747 7748 begin 7749 if not Is_Compilation_Unit (E) 7750 or else Ekind (E) /= E_Package 7751 or else In_Private_Part (E) 7752 then 7753 return False; 7754 end if; 7755 7756 Context := Context_Items (Cunit (Main_Unit)); 7757 7758 Clause := First (Context); 7759 while Present (Clause) loop 7760 if Nkind (Clause) = N_With_Clause then 7761 Nam := Name (Clause); 7762 7763 -- If the current scope is part of the context of the main unit, 7764 -- analysis of the corresponding with_clause is not complete, and 7765 -- the entity is not set. We use the Chars field directly, which 7766 -- might produce false positives in rare cases, but guarantees 7767 -- that we produce all the instance bodies we will need. 7768 7769 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 7770 or else (Nkind (Nam) = N_Selected_Component 7771 and then Chars (Selector_Name (Nam)) = Chars (E)) 7772 then 7773 return True; 7774 end if; 7775 end if; 7776 7777 Next (Clause); 7778 end loop; 7779 7780 return False; 7781 end In_Main_Context; 7782 7783 --------------------- 7784 -- Inherit_Context -- 7785 --------------------- 7786 7787 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 7788 Current_Context : List_Id; 7789 Current_Unit : Node_Id; 7790 Item : Node_Id; 7791 New_I : Node_Id; 7792 7793 Clause : Node_Id; 7794 OK : Boolean; 7795 Lib_Unit : Node_Id; 7796 7797 begin 7798 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 7799 7800 -- The inherited context is attached to the enclosing compilation 7801 -- unit. This is either the main unit, or the declaration for the 7802 -- main unit (in case the instantiation appears within the package 7803 -- declaration and the main unit is its body). 7804 7805 Current_Unit := Parent (Inst); 7806 while Present (Current_Unit) 7807 and then Nkind (Current_Unit) /= N_Compilation_Unit 7808 loop 7809 Current_Unit := Parent (Current_Unit); 7810 end loop; 7811 7812 Current_Context := Context_Items (Current_Unit); 7813 7814 Item := First (Context_Items (Parent (Gen_Decl))); 7815 while Present (Item) loop 7816 if Nkind (Item) = N_With_Clause then 7817 Lib_Unit := Library_Unit (Item); 7818 7819 -- Take care to prevent direct cyclic with's 7820 7821 if Lib_Unit /= Current_Unit then 7822 7823 -- Do not add a unit if it is already in the context 7824 7825 Clause := First (Current_Context); 7826 OK := True; 7827 while Present (Clause) loop 7828 if Nkind (Clause) = N_With_Clause and then 7829 Library_Unit (Clause) = Lib_Unit 7830 then 7831 OK := False; 7832 exit; 7833 end if; 7834 7835 Next (Clause); 7836 end loop; 7837 7838 if OK then 7839 New_I := New_Copy (Item); 7840 Set_Implicit_With (New_I, True); 7841 Set_Implicit_With_From_Instantiation (New_I, True); 7842 Append (New_I, Current_Context); 7843 end if; 7844 end if; 7845 end if; 7846 7847 Next (Item); 7848 end loop; 7849 end if; 7850 end Inherit_Context; 7851 7852 ---------------- 7853 -- Initialize -- 7854 ---------------- 7855 7856 procedure Initialize is 7857 begin 7858 Generic_Renamings.Init; 7859 Instance_Envs.Init; 7860 Generic_Flags.Init; 7861 Generic_Renamings_HTable.Reset; 7862 Circularity_Detected := False; 7863 Exchanged_Views := No_Elist; 7864 Hidden_Entities := No_Elist; 7865 end Initialize; 7866 7867 ------------------------------------- 7868 -- Insert_Freeze_Node_For_Instance -- 7869 ------------------------------------- 7870 7871 procedure Insert_Freeze_Node_For_Instance 7872 (N : Node_Id; 7873 F_Node : Node_Id) 7874 is 7875 Decl : Node_Id; 7876 Decls : List_Id; 7877 Inst : Entity_Id; 7878 Par_N : Node_Id; 7879 7880 function Enclosing_Body (N : Node_Id) return Node_Id; 7881 -- Find enclosing package or subprogram body, if any. Freeze node 7882 -- may be placed at end of current declarative list if previous 7883 -- instance and current one have different enclosing bodies. 7884 7885 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 7886 -- Find the local instance, if any, that declares the generic that is 7887 -- being instantiated. If present, the freeze node for this instance 7888 -- must follow the freeze node for the previous instance. 7889 7890 -------------------- 7891 -- Enclosing_Body -- 7892 -------------------- 7893 7894 function Enclosing_Body (N : Node_Id) return Node_Id is 7895 P : Node_Id; 7896 7897 begin 7898 P := Parent (N); 7899 while Present (P) 7900 and then Nkind (Parent (P)) /= N_Compilation_Unit 7901 loop 7902 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 7903 if Nkind (Parent (P)) = N_Subunit then 7904 return Corresponding_Stub (Parent (P)); 7905 else 7906 return P; 7907 end if; 7908 end if; 7909 7910 P := True_Parent (P); 7911 end loop; 7912 7913 return Empty; 7914 end Enclosing_Body; 7915 7916 ----------------------- 7917 -- Previous_Instance -- 7918 ----------------------- 7919 7920 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 7921 S : Entity_Id; 7922 7923 begin 7924 S := Scope (Gen); 7925 while Present (S) 7926 and then S /= Standard_Standard 7927 loop 7928 if Is_Generic_Instance (S) 7929 and then In_Same_Source_Unit (S, N) 7930 then 7931 return S; 7932 end if; 7933 7934 S := Scope (S); 7935 end loop; 7936 7937 return Empty; 7938 end Previous_Instance; 7939 7940 -- Start of processing for Insert_Freeze_Node_For_Instance 7941 7942 begin 7943 if not Is_List_Member (F_Node) then 7944 Decl := N; 7945 Decls := List_Containing (N); 7946 Inst := Entity (F_Node); 7947 Par_N := Parent (Decls); 7948 7949 -- When processing a subprogram instantiation, utilize the actual 7950 -- subprogram instantiation rather than its package wrapper as it 7951 -- carries all the context information. 7952 7953 if Is_Wrapper_Package (Inst) then 7954 Inst := Related_Instance (Inst); 7955 end if; 7956 7957 -- If this is a package instance, check whether the generic is 7958 -- declared in a previous instance and the current instance is 7959 -- not within the previous one. 7960 7961 if Present (Generic_Parent (Parent (Inst))) 7962 and then Is_In_Main_Unit (N) 7963 then 7964 declare 7965 Enclosing_N : constant Node_Id := Enclosing_Body (N); 7966 Par_I : constant Entity_Id := 7967 Previous_Instance 7968 (Generic_Parent (Parent (Inst))); 7969 Scop : Entity_Id; 7970 7971 begin 7972 if Present (Par_I) 7973 and then Earlier (N, Freeze_Node (Par_I)) 7974 then 7975 Scop := Scope (Inst); 7976 7977 -- If the current instance is within the one that contains 7978 -- the generic, the freeze node for the current one must 7979 -- appear in the current declarative part. Ditto, if the 7980 -- current instance is within another package instance or 7981 -- within a body that does not enclose the current instance. 7982 -- In these three cases the freeze node of the previous 7983 -- instance is not relevant. 7984 7985 while Present (Scop) 7986 and then Scop /= Standard_Standard 7987 loop 7988 exit when Scop = Par_I 7989 or else 7990 (Is_Generic_Instance (Scop) 7991 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 7992 Scop := Scope (Scop); 7993 end loop; 7994 7995 -- Previous instance encloses current instance 7996 7997 if Scop = Par_I then 7998 null; 7999 8000 -- If the next node is a source body we must freeze in 8001 -- the current scope as well. 8002 8003 elsif Present (Next (N)) 8004 and then Nkind_In (Next (N), 8005 N_Subprogram_Body, N_Package_Body) 8006 and then Comes_From_Source (Next (N)) 8007 then 8008 null; 8009 8010 -- Current instance is within an unrelated instance 8011 8012 elsif Is_Generic_Instance (Scop) then 8013 null; 8014 8015 -- Current instance is within an unrelated body 8016 8017 elsif Present (Enclosing_N) 8018 and then Enclosing_N /= Enclosing_Body (Par_I) 8019 then 8020 null; 8021 8022 else 8023 Insert_After (Freeze_Node (Par_I), F_Node); 8024 return; 8025 end if; 8026 end if; 8027 end; 8028 end if; 8029 8030 -- When the instantiation occurs in a package declaration, append the 8031 -- freeze node to the private declarations (if any). 8032 8033 if Nkind (Par_N) = N_Package_Specification 8034 and then Decls = Visible_Declarations (Par_N) 8035 and then Present (Private_Declarations (Par_N)) 8036 and then not Is_Empty_List (Private_Declarations (Par_N)) 8037 then 8038 Decls := Private_Declarations (Par_N); 8039 Decl := First (Decls); 8040 end if; 8041 8042 -- Determine the proper freeze point of a package instantiation. We 8043 -- adhere to the general rule of a package or subprogram body causing 8044 -- freezing of anything before it in the same declarative region. In 8045 -- this case, the proper freeze point of a package instantiation is 8046 -- before the first source body which follows, or before a stub. This 8047 -- ensures that entities coming from the instance are already frozen 8048 -- and usable in source bodies. 8049 8050 if Nkind (Par_N) /= N_Package_Declaration 8051 and then Ekind (Inst) = E_Package 8052 and then Is_Generic_Instance (Inst) 8053 and then 8054 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 8055 then 8056 while Present (Decl) loop 8057 if (Nkind (Decl) in N_Unit_Body 8058 or else 8059 Nkind (Decl) in N_Body_Stub) 8060 and then Comes_From_Source (Decl) 8061 then 8062 Insert_Before (Decl, F_Node); 8063 return; 8064 end if; 8065 8066 Next (Decl); 8067 end loop; 8068 end if; 8069 8070 -- In a package declaration, or if no previous body, insert at end 8071 -- of list. 8072 8073 Set_Sloc (F_Node, Sloc (Last (Decls))); 8074 Insert_After (Last (Decls), F_Node); 8075 end if; 8076 end Insert_Freeze_Node_For_Instance; 8077 8078 ------------------ 8079 -- Install_Body -- 8080 ------------------ 8081 8082 procedure Install_Body 8083 (Act_Body : Node_Id; 8084 N : Node_Id; 8085 Gen_Body : Node_Id; 8086 Gen_Decl : Node_Id) 8087 is 8088 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 8089 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 8090 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 8091 Par : constant Entity_Id := Scope (Gen_Id); 8092 Gen_Unit : constant Node_Id := 8093 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 8094 Orig_Body : Node_Id := Gen_Body; 8095 F_Node : Node_Id; 8096 Body_Unit : Node_Id; 8097 8098 Must_Delay : Boolean; 8099 8100 function Enclosing_Subp (Id : Entity_Id) return Entity_Id; 8101 -- Find subprogram (if any) that encloses instance and/or generic body 8102 8103 function True_Sloc (N : Node_Id) return Source_Ptr; 8104 -- If the instance is nested inside a generic unit, the Sloc of the 8105 -- instance indicates the place of the original definition, not the 8106 -- point of the current enclosing instance. Pending a better usage of 8107 -- Slocs to indicate instantiation places, we determine the place of 8108 -- origin of a node by finding the maximum sloc of any ancestor node. 8109 -- Why is this not equivalent to Top_Level_Location ??? 8110 8111 -------------------- 8112 -- Enclosing_Subp -- 8113 -------------------- 8114 8115 function Enclosing_Subp (Id : Entity_Id) return Entity_Id is 8116 Scop : Entity_Id; 8117 8118 begin 8119 Scop := Scope (Id); 8120 while Scop /= Standard_Standard 8121 and then not Is_Overloadable (Scop) 8122 loop 8123 Scop := Scope (Scop); 8124 end loop; 8125 8126 return Scop; 8127 end Enclosing_Subp; 8128 8129 --------------- 8130 -- True_Sloc -- 8131 --------------- 8132 8133 function True_Sloc (N : Node_Id) return Source_Ptr is 8134 Res : Source_Ptr; 8135 N1 : Node_Id; 8136 8137 begin 8138 Res := Sloc (N); 8139 N1 := N; 8140 while Present (N1) and then N1 /= Act_Unit loop 8141 if Sloc (N1) > Res then 8142 Res := Sloc (N1); 8143 end if; 8144 8145 N1 := Parent (N1); 8146 end loop; 8147 8148 return Res; 8149 end True_Sloc; 8150 8151 -- Start of processing for Install_Body 8152 8153 begin 8154 -- If the body is a subunit, the freeze point is the corresponding stub 8155 -- in the current compilation, not the subunit itself. 8156 8157 if Nkind (Parent (Gen_Body)) = N_Subunit then 8158 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 8159 else 8160 Orig_Body := Gen_Body; 8161 end if; 8162 8163 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 8164 8165 -- If the instantiation and the generic definition appear in the same 8166 -- package declaration, this is an early instantiation. If they appear 8167 -- in the same declarative part, it is an early instantiation only if 8168 -- the generic body appears textually later, and the generic body is 8169 -- also in the main unit. 8170 8171 -- If instance is nested within a subprogram, and the generic body is 8172 -- not, the instance is delayed because the enclosing body is. If 8173 -- instance and body are within the same scope, or the same sub- 8174 -- program body, indicate explicitly that the instance is delayed. 8175 8176 Must_Delay := 8177 (Gen_Unit = Act_Unit 8178 and then (Nkind_In (Gen_Unit, N_Package_Declaration, 8179 N_Generic_Package_Declaration) 8180 or else (Gen_Unit = Body_Unit 8181 and then True_Sloc (N) < Sloc (Orig_Body))) 8182 and then Is_In_Main_Unit (Gen_Unit) 8183 and then (Scope (Act_Id) = Scope (Gen_Id) 8184 or else 8185 Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id))); 8186 8187 -- If this is an early instantiation, the freeze node is placed after 8188 -- the generic body. Otherwise, if the generic appears in an instance, 8189 -- we cannot freeze the current instance until the outer one is frozen. 8190 -- This is only relevant if the current instance is nested within some 8191 -- inner scope not itself within the outer instance. If this scope is 8192 -- a package body in the same declarative part as the outer instance, 8193 -- then that body needs to be frozen after the outer instance. Finally, 8194 -- if no delay is needed, we place the freeze node at the end of the 8195 -- current declarative part. 8196 8197 if Expander_Active then 8198 Ensure_Freeze_Node (Act_Id); 8199 F_Node := Freeze_Node (Act_Id); 8200 8201 if Must_Delay then 8202 Insert_After (Orig_Body, F_Node); 8203 8204 elsif Is_Generic_Instance (Par) 8205 and then Present (Freeze_Node (Par)) 8206 and then Scope (Act_Id) /= Par 8207 then 8208 -- Freeze instance of inner generic after instance of enclosing 8209 -- generic. 8210 8211 if In_Same_Declarative_Part (Freeze_Node (Par), N) then 8212 8213 -- Handle the following case: 8214 8215 -- package Parent_Inst is new ... 8216 -- Parent_Inst [] 8217 8218 -- procedure P ... -- this body freezes Parent_Inst 8219 8220 -- package Inst is new ... 8221 8222 -- In this particular scenario, the freeze node for Inst must 8223 -- be inserted in the same manner as that of Parent_Inst - 8224 -- before the next source body or at the end of the declarative 8225 -- list (body not available). If body P did not exist and 8226 -- Parent_Inst was frozen after Inst, either by a body 8227 -- following Inst or at the end of the declarative region, the 8228 -- freeze node for Inst must be inserted after that of 8229 -- Parent_Inst. This relation is established by comparing the 8230 -- Slocs of Parent_Inst freeze node and Inst. 8231 8232 if List_Containing (Get_Package_Instantiation_Node (Par)) = 8233 List_Containing (N) 8234 and then Sloc (Freeze_Node (Par)) < Sloc (N) 8235 then 8236 Insert_Freeze_Node_For_Instance (N, F_Node); 8237 else 8238 Insert_After (Freeze_Node (Par), F_Node); 8239 end if; 8240 8241 -- Freeze package enclosing instance of inner generic after 8242 -- instance of enclosing generic. 8243 8244 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 8245 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) 8246 then 8247 declare 8248 Enclosing : Entity_Id; 8249 8250 begin 8251 Enclosing := Corresponding_Spec (Parent (N)); 8252 8253 if No (Enclosing) then 8254 Enclosing := Defining_Entity (Parent (N)); 8255 end if; 8256 8257 Insert_Freeze_Node_For_Instance (N, F_Node); 8258 Ensure_Freeze_Node (Enclosing); 8259 8260 if not Is_List_Member (Freeze_Node (Enclosing)) then 8261 8262 -- The enclosing context is a subunit, insert the freeze 8263 -- node after the stub. 8264 8265 if Nkind (Parent (Parent (N))) = N_Subunit then 8266 Insert_Freeze_Node_For_Instance 8267 (Corresponding_Stub (Parent (Parent (N))), 8268 Freeze_Node (Enclosing)); 8269 8270 -- The enclosing context is a package with a stub body 8271 -- which has already been replaced by the real body. 8272 -- Insert the freeze node after the actual body. 8273 8274 elsif Ekind (Enclosing) = E_Package 8275 and then Present (Body_Entity (Enclosing)) 8276 and then Was_Originally_Stub 8277 (Parent (Body_Entity (Enclosing))) 8278 then 8279 Insert_Freeze_Node_For_Instance 8280 (Parent (Body_Entity (Enclosing)), 8281 Freeze_Node (Enclosing)); 8282 8283 -- The parent instance has been frozen before the body of 8284 -- the enclosing package, insert the freeze node after 8285 -- the body. 8286 8287 elsif List_Containing (Freeze_Node (Par)) = 8288 List_Containing (Parent (N)) 8289 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 8290 then 8291 Insert_Freeze_Node_For_Instance 8292 (Parent (N), Freeze_Node (Enclosing)); 8293 8294 else 8295 Insert_After 8296 (Freeze_Node (Par), Freeze_Node (Enclosing)); 8297 end if; 8298 end if; 8299 end; 8300 8301 else 8302 Insert_Freeze_Node_For_Instance (N, F_Node); 8303 end if; 8304 8305 else 8306 Insert_Freeze_Node_For_Instance (N, F_Node); 8307 end if; 8308 end if; 8309 8310 Set_Is_Frozen (Act_Id); 8311 Insert_Before (N, Act_Body); 8312 Mark_Rewrite_Insertion (Act_Body); 8313 end Install_Body; 8314 8315 ----------------------------- 8316 -- Install_Formal_Packages -- 8317 ----------------------------- 8318 8319 procedure Install_Formal_Packages (Par : Entity_Id) is 8320 E : Entity_Id; 8321 Gen : Entity_Id; 8322 Gen_E : Entity_Id := Empty; 8323 8324 begin 8325 E := First_Entity (Par); 8326 8327 -- If we are installing an instance parent, locate the formal packages 8328 -- of its generic parent. 8329 8330 if Is_Generic_Instance (Par) then 8331 Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par))); 8332 Gen_E := First_Entity (Gen); 8333 end if; 8334 8335 while Present (E) loop 8336 if Ekind (E) = E_Package 8337 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 8338 then 8339 -- If this is the renaming for the parent instance, done 8340 8341 if Renamed_Object (E) = Par then 8342 exit; 8343 8344 -- The visibility of a formal of an enclosing generic is already 8345 -- correct. 8346 8347 elsif Denotes_Formal_Package (E) then 8348 null; 8349 8350 elsif Present (Associated_Formal_Package (E)) then 8351 Check_Generic_Actuals (Renamed_Object (E), True); 8352 Set_Is_Hidden (E, False); 8353 8354 -- Find formal package in generic unit that corresponds to 8355 -- (instance of) formal package in instance. 8356 8357 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 8358 Next_Entity (Gen_E); 8359 end loop; 8360 8361 if Present (Gen_E) then 8362 Map_Formal_Package_Entities (Gen_E, E); 8363 end if; 8364 end if; 8365 end if; 8366 8367 Next_Entity (E); 8368 if Present (Gen_E) then 8369 Next_Entity (Gen_E); 8370 end if; 8371 end loop; 8372 end Install_Formal_Packages; 8373 8374 -------------------- 8375 -- Install_Parent -- 8376 -------------------- 8377 8378 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 8379 Ancestors : constant Elist_Id := New_Elmt_List; 8380 S : constant Entity_Id := Current_Scope; 8381 Inst_Par : Entity_Id; 8382 First_Par : Entity_Id; 8383 Inst_Node : Node_Id; 8384 Gen_Par : Entity_Id; 8385 First_Gen : Entity_Id; 8386 Elmt : Elmt_Id; 8387 8388 procedure Install_Noninstance_Specs (Par : Entity_Id); 8389 -- Install the scopes of noninstance parent units ending with Par 8390 8391 procedure Install_Spec (Par : Entity_Id); 8392 -- The child unit is within the declarative part of the parent, so 8393 -- the declarations within the parent are immediately visible. 8394 8395 ------------------------------- 8396 -- Install_Noninstance_Specs -- 8397 ------------------------------- 8398 8399 procedure Install_Noninstance_Specs (Par : Entity_Id) is 8400 begin 8401 if Present (Par) 8402 and then Par /= Standard_Standard 8403 and then not In_Open_Scopes (Par) 8404 then 8405 Install_Noninstance_Specs (Scope (Par)); 8406 Install_Spec (Par); 8407 end if; 8408 end Install_Noninstance_Specs; 8409 8410 ------------------ 8411 -- Install_Spec -- 8412 ------------------ 8413 8414 procedure Install_Spec (Par : Entity_Id) is 8415 Spec : constant Node_Id := 8416 Specification (Unit_Declaration_Node (Par)); 8417 8418 begin 8419 -- If this parent of the child instance is a top-level unit, 8420 -- then record the unit and its visibility for later resetting 8421 -- in Remove_Parent. We exclude units that are generic instances, 8422 -- as we only want to record this information for the ultimate 8423 -- top-level noninstance parent (is that always correct???). 8424 8425 if Scope (Par) = Standard_Standard 8426 and then not Is_Generic_Instance (Par) 8427 then 8428 Parent_Unit_Visible := Is_Immediately_Visible (Par); 8429 Instance_Parent_Unit := Par; 8430 end if; 8431 8432 -- Open the parent scope and make it and its declarations visible. 8433 -- If this point is not within a body, then only the visible 8434 -- declarations should be made visible, and installation of the 8435 -- private declarations is deferred until the appropriate point 8436 -- within analysis of the spec being instantiated (see the handling 8437 -- of parent visibility in Analyze_Package_Specification). This is 8438 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 8439 -- private view problems that occur when compiling instantiations of 8440 -- a generic child of that package (Generic_Dispatching_Constructor). 8441 -- If the instance freezes a tagged type, inlinings of operations 8442 -- from Ada.Tags may need the full view of type Tag. If inlining took 8443 -- proper account of establishing visibility of inlined subprograms' 8444 -- parents then it should be possible to remove this 8445 -- special check. ??? 8446 8447 Push_Scope (Par); 8448 Set_Is_Immediately_Visible (Par); 8449 Install_Visible_Declarations (Par); 8450 Set_Use (Visible_Declarations (Spec)); 8451 8452 if In_Body or else Is_RTU (Par, Ada_Tags) then 8453 Install_Private_Declarations (Par); 8454 Set_Use (Private_Declarations (Spec)); 8455 end if; 8456 end Install_Spec; 8457 8458 -- Start of processing for Install_Parent 8459 8460 begin 8461 -- We need to install the parent instance to compile the instantiation 8462 -- of the child, but the child instance must appear in the current 8463 -- scope. Given that we cannot place the parent above the current scope 8464 -- in the scope stack, we duplicate the current scope and unstack both 8465 -- after the instantiation is complete. 8466 8467 -- If the parent is itself the instantiation of a child unit, we must 8468 -- also stack the instantiation of its parent, and so on. Each such 8469 -- ancestor is the prefix of the name in a prior instantiation. 8470 8471 -- If this is a nested instance, the parent unit itself resolves to 8472 -- a renaming of the parent instance, whose declaration we need. 8473 8474 -- Finally, the parent may be a generic (not an instance) when the 8475 -- child unit appears as a formal package. 8476 8477 Inst_Par := P; 8478 8479 if Present (Renamed_Entity (Inst_Par)) then 8480 Inst_Par := Renamed_Entity (Inst_Par); 8481 end if; 8482 8483 First_Par := Inst_Par; 8484 8485 Gen_Par := 8486 Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); 8487 8488 First_Gen := Gen_Par; 8489 8490 while Present (Gen_Par) 8491 and then Is_Child_Unit (Gen_Par) 8492 loop 8493 -- Load grandparent instance as well 8494 8495 Inst_Node := Get_Package_Instantiation_Node (Inst_Par); 8496 8497 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 8498 Inst_Par := Entity (Prefix (Name (Inst_Node))); 8499 8500 if Present (Renamed_Entity (Inst_Par)) then 8501 Inst_Par := Renamed_Entity (Inst_Par); 8502 end if; 8503 8504 Gen_Par := 8505 Generic_Parent 8506 (Specification (Unit_Declaration_Node (Inst_Par))); 8507 8508 if Present (Gen_Par) then 8509 Prepend_Elmt (Inst_Par, Ancestors); 8510 8511 else 8512 -- Parent is not the name of an instantiation 8513 8514 Install_Noninstance_Specs (Inst_Par); 8515 exit; 8516 end if; 8517 8518 else 8519 -- Previous error 8520 8521 exit; 8522 end if; 8523 end loop; 8524 8525 if Present (First_Gen) then 8526 Append_Elmt (First_Par, Ancestors); 8527 else 8528 Install_Noninstance_Specs (First_Par); 8529 end if; 8530 8531 if not Is_Empty_Elmt_List (Ancestors) then 8532 Elmt := First_Elmt (Ancestors); 8533 while Present (Elmt) loop 8534 Install_Spec (Node (Elmt)); 8535 Install_Formal_Packages (Node (Elmt)); 8536 Next_Elmt (Elmt); 8537 end loop; 8538 end if; 8539 8540 if not In_Body then 8541 Push_Scope (S); 8542 end if; 8543 end Install_Parent; 8544 8545 ------------------------------- 8546 -- Install_Hidden_Primitives -- 8547 ------------------------------- 8548 8549 procedure Install_Hidden_Primitives 8550 (Prims_List : in out Elist_Id; 8551 Gen_T : Entity_Id; 8552 Act_T : Entity_Id) 8553 is 8554 Elmt : Elmt_Id; 8555 List : Elist_Id := No_Elist; 8556 Prim_G_Elmt : Elmt_Id; 8557 Prim_A_Elmt : Elmt_Id; 8558 Prim_G : Node_Id; 8559 Prim_A : Node_Id; 8560 8561 begin 8562 -- No action needed in case of serious errors because we cannot trust 8563 -- in the order of primitives 8564 8565 if Serious_Errors_Detected > 0 then 8566 return; 8567 8568 -- No action possible if we don't have available the list of primitive 8569 -- operations 8570 8571 elsif No (Gen_T) 8572 or else not Is_Record_Type (Gen_T) 8573 or else not Is_Tagged_Type (Gen_T) 8574 or else not Is_Record_Type (Act_T) 8575 or else not Is_Tagged_Type (Act_T) 8576 then 8577 return; 8578 8579 -- There is no need to handle interface types since their primitives 8580 -- cannot be hidden 8581 8582 elsif Is_Interface (Gen_T) then 8583 return; 8584 end if; 8585 8586 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 8587 8588 if not Is_Class_Wide_Type (Act_T) then 8589 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 8590 else 8591 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 8592 end if; 8593 8594 loop 8595 -- Skip predefined primitives in the generic formal 8596 8597 while Present (Prim_G_Elmt) 8598 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 8599 loop 8600 Next_Elmt (Prim_G_Elmt); 8601 end loop; 8602 8603 -- Skip predefined primitives in the generic actual 8604 8605 while Present (Prim_A_Elmt) 8606 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 8607 loop 8608 Next_Elmt (Prim_A_Elmt); 8609 end loop; 8610 8611 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 8612 8613 Prim_G := Node (Prim_G_Elmt); 8614 Prim_A := Node (Prim_A_Elmt); 8615 8616 -- There is no need to handle interface primitives because their 8617 -- primitives are not hidden 8618 8619 exit when Present (Interface_Alias (Prim_G)); 8620 8621 -- Here we install one hidden primitive 8622 8623 if Chars (Prim_G) /= Chars (Prim_A) 8624 and then Has_Suffix (Prim_A, 'P') 8625 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 8626 then 8627 Set_Chars (Prim_A, Chars (Prim_G)); 8628 8629 if List = No_Elist then 8630 List := New_Elmt_List; 8631 end if; 8632 8633 Append_Elmt (Prim_A, List); 8634 end if; 8635 8636 Next_Elmt (Prim_A_Elmt); 8637 Next_Elmt (Prim_G_Elmt); 8638 end loop; 8639 8640 -- Append the elements to the list of temporarily visible primitives 8641 -- avoiding duplicates. 8642 8643 if Present (List) then 8644 if No (Prims_List) then 8645 Prims_List := New_Elmt_List; 8646 end if; 8647 8648 Elmt := First_Elmt (List); 8649 while Present (Elmt) loop 8650 Append_Unique_Elmt (Node (Elmt), Prims_List); 8651 Next_Elmt (Elmt); 8652 end loop; 8653 end if; 8654 end Install_Hidden_Primitives; 8655 8656 ------------------------------- 8657 -- Restore_Hidden_Primitives -- 8658 ------------------------------- 8659 8660 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 8661 Prim_Elmt : Elmt_Id; 8662 Prim : Node_Id; 8663 8664 begin 8665 if Prims_List /= No_Elist then 8666 Prim_Elmt := First_Elmt (Prims_List); 8667 while Present (Prim_Elmt) loop 8668 Prim := Node (Prim_Elmt); 8669 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 8670 Next_Elmt (Prim_Elmt); 8671 end loop; 8672 8673 Prims_List := No_Elist; 8674 end if; 8675 end Restore_Hidden_Primitives; 8676 8677 -------------------------------- 8678 -- Instantiate_Formal_Package -- 8679 -------------------------------- 8680 8681 function Instantiate_Formal_Package 8682 (Formal : Node_Id; 8683 Actual : Node_Id; 8684 Analyzed_Formal : Node_Id) return List_Id 8685 is 8686 Loc : constant Source_Ptr := Sloc (Actual); 8687 Actual_Pack : Entity_Id; 8688 Formal_Pack : Entity_Id; 8689 Gen_Parent : Entity_Id; 8690 Decls : List_Id; 8691 Nod : Node_Id; 8692 Parent_Spec : Node_Id; 8693 8694 procedure Find_Matching_Actual 8695 (F : Node_Id; 8696 Act : in out Entity_Id); 8697 -- We need to associate each formal entity in the formal package 8698 -- with the corresponding entity in the actual package. The actual 8699 -- package has been analyzed and possibly expanded, and as a result 8700 -- there is no one-to-one correspondence between the two lists (for 8701 -- example, the actual may include subtypes, itypes, and inherited 8702 -- primitive operations, interspersed among the renaming declarations 8703 -- for the actuals) . We retrieve the corresponding actual by name 8704 -- because each actual has the same name as the formal, and they do 8705 -- appear in the same order. 8706 8707 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 8708 -- Retrieve entity of defining entity of generic formal parameter. 8709 -- Only the declarations of formals need to be considered when 8710 -- linking them to actuals, but the declarative list may include 8711 -- internal entities generated during analysis, and those are ignored. 8712 8713 procedure Match_Formal_Entity 8714 (Formal_Node : Node_Id; 8715 Formal_Ent : Entity_Id; 8716 Actual_Ent : Entity_Id); 8717 -- Associates the formal entity with the actual. In the case 8718 -- where Formal_Ent is a formal package, this procedure iterates 8719 -- through all of its formals and enters associations between the 8720 -- actuals occurring in the formal package's corresponding actual 8721 -- package (given by Actual_Ent) and the formal package's formal 8722 -- parameters. This procedure recurses if any of the parameters is 8723 -- itself a package. 8724 8725 function Is_Instance_Of 8726 (Act_Spec : Entity_Id; 8727 Gen_Anc : Entity_Id) return Boolean; 8728 -- The actual can be an instantiation of a generic within another 8729 -- instance, in which case there is no direct link from it to the 8730 -- original generic ancestor. In that case, we recognize that the 8731 -- ultimate ancestor is the same by examining names and scopes. 8732 8733 procedure Process_Nested_Formal (Formal : Entity_Id); 8734 -- If the current formal is declared with a box, its own formals are 8735 -- visible in the instance, as they were in the generic, and their 8736 -- Hidden flag must be reset. If some of these formals are themselves 8737 -- packages declared with a box, the processing must be recursive. 8738 8739 -------------------------- 8740 -- Find_Matching_Actual -- 8741 -------------------------- 8742 8743 procedure Find_Matching_Actual 8744 (F : Node_Id; 8745 Act : in out Entity_Id) 8746 is 8747 Formal_Ent : Entity_Id; 8748 8749 begin 8750 case Nkind (Original_Node (F)) is 8751 when N_Formal_Object_Declaration | 8752 N_Formal_Type_Declaration => 8753 Formal_Ent := Defining_Identifier (F); 8754 8755 while Chars (Act) /= Chars (Formal_Ent) loop 8756 Next_Entity (Act); 8757 end loop; 8758 8759 when N_Formal_Subprogram_Declaration | 8760 N_Formal_Package_Declaration | 8761 N_Package_Declaration | 8762 N_Generic_Package_Declaration => 8763 Formal_Ent := Defining_Entity (F); 8764 8765 while Chars (Act) /= Chars (Formal_Ent) loop 8766 Next_Entity (Act); 8767 end loop; 8768 8769 when others => 8770 raise Program_Error; 8771 end case; 8772 end Find_Matching_Actual; 8773 8774 ------------------------- 8775 -- Match_Formal_Entity -- 8776 ------------------------- 8777 8778 procedure Match_Formal_Entity 8779 (Formal_Node : Node_Id; 8780 Formal_Ent : Entity_Id; 8781 Actual_Ent : Entity_Id) 8782 is 8783 Act_Pkg : Entity_Id; 8784 8785 begin 8786 Set_Instance_Of (Formal_Ent, Actual_Ent); 8787 8788 if Ekind (Actual_Ent) = E_Package then 8789 8790 -- Record associations for each parameter 8791 8792 Act_Pkg := Actual_Ent; 8793 8794 declare 8795 A_Ent : Entity_Id := First_Entity (Act_Pkg); 8796 F_Ent : Entity_Id; 8797 F_Node : Node_Id; 8798 8799 Gen_Decl : Node_Id; 8800 Formals : List_Id; 8801 Actual : Entity_Id; 8802 8803 begin 8804 -- Retrieve the actual given in the formal package declaration 8805 8806 Actual := Entity (Name (Original_Node (Formal_Node))); 8807 8808 -- The actual in the formal package declaration may be a 8809 -- renamed generic package, in which case we want to retrieve 8810 -- the original generic in order to traverse its formal part. 8811 8812 if Present (Renamed_Entity (Actual)) then 8813 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 8814 else 8815 Gen_Decl := Unit_Declaration_Node (Actual); 8816 end if; 8817 8818 Formals := Generic_Formal_Declarations (Gen_Decl); 8819 8820 if Present (Formals) then 8821 F_Node := First_Non_Pragma (Formals); 8822 else 8823 F_Node := Empty; 8824 end if; 8825 8826 while Present (A_Ent) 8827 and then Present (F_Node) 8828 and then A_Ent /= First_Private_Entity (Act_Pkg) 8829 loop 8830 F_Ent := Get_Formal_Entity (F_Node); 8831 8832 if Present (F_Ent) then 8833 8834 -- This is a formal of the original package. Record 8835 -- association and recurse. 8836 8837 Find_Matching_Actual (F_Node, A_Ent); 8838 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 8839 Next_Entity (A_Ent); 8840 end if; 8841 8842 Next_Non_Pragma (F_Node); 8843 end loop; 8844 end; 8845 end if; 8846 end Match_Formal_Entity; 8847 8848 ----------------------- 8849 -- Get_Formal_Entity -- 8850 ----------------------- 8851 8852 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 8853 Kind : constant Node_Kind := Nkind (Original_Node (N)); 8854 begin 8855 case Kind is 8856 when N_Formal_Object_Declaration => 8857 return Defining_Identifier (N); 8858 8859 when N_Formal_Type_Declaration => 8860 return Defining_Identifier (N); 8861 8862 when N_Formal_Subprogram_Declaration => 8863 return Defining_Unit_Name (Specification (N)); 8864 8865 when N_Formal_Package_Declaration => 8866 return Defining_Identifier (Original_Node (N)); 8867 8868 when N_Generic_Package_Declaration => 8869 return Defining_Identifier (Original_Node (N)); 8870 8871 -- All other declarations are introduced by semantic analysis and 8872 -- have no match in the actual. 8873 8874 when others => 8875 return Empty; 8876 end case; 8877 end Get_Formal_Entity; 8878 8879 -------------------- 8880 -- Is_Instance_Of -- 8881 -------------------- 8882 8883 function Is_Instance_Of 8884 (Act_Spec : Entity_Id; 8885 Gen_Anc : Entity_Id) return Boolean 8886 is 8887 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 8888 8889 begin 8890 if No (Gen_Par) then 8891 return False; 8892 8893 -- Simplest case: the generic parent of the actual is the formal 8894 8895 elsif Gen_Par = Gen_Anc then 8896 return True; 8897 8898 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 8899 return False; 8900 8901 -- The actual may be obtained through several instantiations. Its 8902 -- scope must itself be an instance of a generic declared in the 8903 -- same scope as the formal. Any other case is detected above. 8904 8905 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 8906 return False; 8907 8908 else 8909 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 8910 end if; 8911 end Is_Instance_Of; 8912 8913 --------------------------- 8914 -- Process_Nested_Formal -- 8915 --------------------------- 8916 8917 procedure Process_Nested_Formal (Formal : Entity_Id) is 8918 Ent : Entity_Id; 8919 8920 begin 8921 if Present (Associated_Formal_Package (Formal)) 8922 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 8923 then 8924 Ent := First_Entity (Formal); 8925 while Present (Ent) loop 8926 Set_Is_Hidden (Ent, False); 8927 Set_Is_Visible_Formal (Ent); 8928 Set_Is_Potentially_Use_Visible 8929 (Ent, Is_Potentially_Use_Visible (Formal)); 8930 8931 if Ekind (Ent) = E_Package then 8932 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 8933 Process_Nested_Formal (Ent); 8934 end if; 8935 8936 Next_Entity (Ent); 8937 end loop; 8938 end if; 8939 end Process_Nested_Formal; 8940 8941 -- Start of processing for Instantiate_Formal_Package 8942 8943 begin 8944 Analyze (Actual); 8945 8946 if not Is_Entity_Name (Actual) 8947 or else Ekind (Entity (Actual)) /= E_Package 8948 then 8949 Error_Msg_N 8950 ("expect package instance to instantiate formal", Actual); 8951 Abandon_Instantiation (Actual); 8952 raise Program_Error; 8953 8954 else 8955 Actual_Pack := Entity (Actual); 8956 Set_Is_Instantiated (Actual_Pack); 8957 8958 -- The actual may be a renamed package, or an outer generic formal 8959 -- package whose instantiation is converted into a renaming. 8960 8961 if Present (Renamed_Object (Actual_Pack)) then 8962 Actual_Pack := Renamed_Object (Actual_Pack); 8963 end if; 8964 8965 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 8966 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 8967 Formal_Pack := Defining_Identifier (Analyzed_Formal); 8968 else 8969 Gen_Parent := 8970 Generic_Parent (Specification (Analyzed_Formal)); 8971 Formal_Pack := 8972 Defining_Unit_Name (Specification (Analyzed_Formal)); 8973 end if; 8974 8975 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 8976 Parent_Spec := Specification (Unit_Declaration_Node (Actual_Pack)); 8977 else 8978 Parent_Spec := Parent (Actual_Pack); 8979 end if; 8980 8981 if Gen_Parent = Any_Id then 8982 Error_Msg_N 8983 ("previous error in declaration of formal package", Actual); 8984 Abandon_Instantiation (Actual); 8985 8986 elsif 8987 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) 8988 then 8989 null; 8990 8991 else 8992 Error_Msg_NE 8993 ("actual parameter must be instance of&", Actual, Gen_Parent); 8994 Abandon_Instantiation (Actual); 8995 end if; 8996 8997 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 8998 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 8999 9000 Nod := 9001 Make_Package_Renaming_Declaration (Loc, 9002 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 9003 Name => New_Reference_To (Actual_Pack, Loc)); 9004 9005 Set_Associated_Formal_Package (Defining_Unit_Name (Nod), 9006 Defining_Identifier (Formal)); 9007 Decls := New_List (Nod); 9008 9009 -- If the formal F has a box, then the generic declarations are 9010 -- visible in the generic G. In an instance of G, the corresponding 9011 -- entities in the actual for F (which are the actuals for the 9012 -- instantiation of the generic that F denotes) must also be made 9013 -- visible for analysis of the current instance. On exit from the 9014 -- current instance, those entities are made private again. If the 9015 -- actual is currently in use, these entities are also use-visible. 9016 9017 -- The loop through the actual entities also steps through the formal 9018 -- entities and enters associations from formals to actuals into the 9019 -- renaming map. This is necessary to properly handle checking of 9020 -- actual parameter associations for later formals that depend on 9021 -- actuals declared in the formal package. 9022 9023 -- In Ada 2005, partial parametrization requires that we make visible 9024 -- the actuals corresponding to formals that were defaulted in the 9025 -- formal package. There formals are identified because they remain 9026 -- formal generics within the formal package, rather than being 9027 -- renamings of the actuals supplied. 9028 9029 declare 9030 Gen_Decl : constant Node_Id := 9031 Unit_Declaration_Node (Gen_Parent); 9032 Formals : constant List_Id := 9033 Generic_Formal_Declarations (Gen_Decl); 9034 9035 Actual_Ent : Entity_Id; 9036 Actual_Of_Formal : Node_Id; 9037 Formal_Node : Node_Id; 9038 Formal_Ent : Entity_Id; 9039 9040 begin 9041 if Present (Formals) then 9042 Formal_Node := First_Non_Pragma (Formals); 9043 else 9044 Formal_Node := Empty; 9045 end if; 9046 9047 Actual_Ent := First_Entity (Actual_Pack); 9048 Actual_Of_Formal := 9049 First (Visible_Declarations (Specification (Analyzed_Formal))); 9050 while Present (Actual_Ent) 9051 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9052 loop 9053 if Present (Formal_Node) then 9054 Formal_Ent := Get_Formal_Entity (Formal_Node); 9055 9056 if Present (Formal_Ent) then 9057 Find_Matching_Actual (Formal_Node, Actual_Ent); 9058 Match_Formal_Entity 9059 (Formal_Node, Formal_Ent, Actual_Ent); 9060 9061 -- We iterate at the same time over the actuals of the 9062 -- local package created for the formal, to determine 9063 -- which one of the formals of the original generic were 9064 -- defaulted in the formal. The corresponding actual 9065 -- entities are visible in the enclosing instance. 9066 9067 if Box_Present (Formal) 9068 or else 9069 (Present (Actual_Of_Formal) 9070 and then 9071 Is_Generic_Formal 9072 (Get_Formal_Entity (Actual_Of_Formal))) 9073 then 9074 Set_Is_Hidden (Actual_Ent, False); 9075 Set_Is_Visible_Formal (Actual_Ent); 9076 Set_Is_Potentially_Use_Visible 9077 (Actual_Ent, In_Use (Actual_Pack)); 9078 9079 if Ekind (Actual_Ent) = E_Package then 9080 Process_Nested_Formal (Actual_Ent); 9081 end if; 9082 9083 else 9084 Set_Is_Hidden (Actual_Ent); 9085 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 9086 end if; 9087 end if; 9088 9089 Next_Non_Pragma (Formal_Node); 9090 Next (Actual_Of_Formal); 9091 9092 else 9093 -- No further formals to match, but the generic part may 9094 -- contain inherited operation that are not hidden in the 9095 -- enclosing instance. 9096 9097 Next_Entity (Actual_Ent); 9098 end if; 9099 end loop; 9100 9101 -- Inherited subprograms generated by formal derived types are 9102 -- also visible if the types are. 9103 9104 Actual_Ent := First_Entity (Actual_Pack); 9105 while Present (Actual_Ent) 9106 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9107 loop 9108 if Is_Overloadable (Actual_Ent) 9109 and then 9110 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 9111 and then 9112 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 9113 then 9114 Set_Is_Hidden (Actual_Ent, False); 9115 Set_Is_Potentially_Use_Visible 9116 (Actual_Ent, In_Use (Actual_Pack)); 9117 end if; 9118 9119 Next_Entity (Actual_Ent); 9120 end loop; 9121 end; 9122 9123 -- If the formal is not declared with a box, reanalyze it as an 9124 -- abbreviated instantiation, to verify the matching rules of 12.7. 9125 -- The actual checks are performed after the generic associations 9126 -- have been analyzed, to guarantee the same visibility for this 9127 -- instantiation and for the actuals. 9128 9129 -- In Ada 2005, the generic associations for the formal can include 9130 -- defaulted parameters. These are ignored during check. This 9131 -- internal instantiation is removed from the tree after conformance 9132 -- checking, because it contains formal declarations for those 9133 -- defaulted parameters, and those should not reach the back-end. 9134 9135 if not Box_Present (Formal) then 9136 declare 9137 I_Pack : constant Entity_Id := 9138 Make_Temporary (Sloc (Actual), 'P'); 9139 9140 begin 9141 Set_Is_Internal (I_Pack); 9142 9143 Append_To (Decls, 9144 Make_Package_Instantiation (Sloc (Actual), 9145 Defining_Unit_Name => I_Pack, 9146 Name => 9147 New_Occurrence_Of 9148 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 9149 Generic_Associations => 9150 Generic_Associations (Formal))); 9151 end; 9152 end if; 9153 9154 return Decls; 9155 end if; 9156 end Instantiate_Formal_Package; 9157 9158 ----------------------------------- 9159 -- Instantiate_Formal_Subprogram -- 9160 ----------------------------------- 9161 9162 function Instantiate_Formal_Subprogram 9163 (Formal : Node_Id; 9164 Actual : Node_Id; 9165 Analyzed_Formal : Node_Id) return Node_Id 9166 is 9167 Loc : Source_Ptr; 9168 Formal_Sub : constant Entity_Id := 9169 Defining_Unit_Name (Specification (Formal)); 9170 Analyzed_S : constant Entity_Id := 9171 Defining_Unit_Name (Specification (Analyzed_Formal)); 9172 Decl_Node : Node_Id; 9173 Nam : Node_Id; 9174 New_Spec : Node_Id; 9175 9176 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 9177 -- If the generic is a child unit, the parent has been installed on the 9178 -- scope stack, but a default subprogram cannot resolve to something on 9179 -- the parent because that parent is not really part of the visible 9180 -- context (it is there to resolve explicit local entities). If the 9181 -- default has resolved in this way, we remove the entity from 9182 -- immediate visibility and analyze the node again to emit an error 9183 -- message or find another visible candidate. 9184 9185 procedure Valid_Actual_Subprogram (Act : Node_Id); 9186 -- Perform legality check and raise exception on failure 9187 9188 ----------------------- 9189 -- From_Parent_Scope -- 9190 ----------------------- 9191 9192 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 9193 Gen_Scope : Node_Id; 9194 9195 begin 9196 Gen_Scope := Scope (Analyzed_S); 9197 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 9198 if Scope (Subp) = Scope (Gen_Scope) then 9199 return True; 9200 end if; 9201 9202 Gen_Scope := Scope (Gen_Scope); 9203 end loop; 9204 9205 return False; 9206 end From_Parent_Scope; 9207 9208 ----------------------------- 9209 -- Valid_Actual_Subprogram -- 9210 ----------------------------- 9211 9212 procedure Valid_Actual_Subprogram (Act : Node_Id) is 9213 Act_E : Entity_Id; 9214 9215 begin 9216 if Is_Entity_Name (Act) then 9217 Act_E := Entity (Act); 9218 9219 elsif Nkind (Act) = N_Selected_Component 9220 and then Is_Entity_Name (Selector_Name (Act)) 9221 then 9222 Act_E := Entity (Selector_Name (Act)); 9223 9224 else 9225 Act_E := Empty; 9226 end if; 9227 9228 if (Present (Act_E) and then Is_Overloadable (Act_E)) 9229 or else Nkind_In (Act, N_Attribute_Reference, 9230 N_Indexed_Component, 9231 N_Character_Literal, 9232 N_Explicit_Dereference) 9233 then 9234 return; 9235 end if; 9236 9237 Error_Msg_NE 9238 ("expect subprogram or entry name in instantiation of&", 9239 Instantiation_Node, Formal_Sub); 9240 Abandon_Instantiation (Instantiation_Node); 9241 9242 end Valid_Actual_Subprogram; 9243 9244 -- Start of processing for Instantiate_Formal_Subprogram 9245 9246 begin 9247 New_Spec := New_Copy_Tree (Specification (Formal)); 9248 9249 -- The tree copy has created the proper instantiation sloc for the 9250 -- new specification. Use this location for all other constructed 9251 -- declarations. 9252 9253 Loc := Sloc (Defining_Unit_Name (New_Spec)); 9254 9255 -- Create new entity for the actual (New_Copy_Tree does not) 9256 9257 Set_Defining_Unit_Name 9258 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 9259 9260 -- Create new entities for the each of the formals in the 9261 -- specification of the renaming declaration built for the actual. 9262 9263 if Present (Parameter_Specifications (New_Spec)) then 9264 declare 9265 F : Node_Id; 9266 begin 9267 F := First (Parameter_Specifications (New_Spec)); 9268 while Present (F) loop 9269 Set_Defining_Identifier (F, 9270 Make_Defining_Identifier (Sloc (F), 9271 Chars => Chars (Defining_Identifier (F)))); 9272 Next (F); 9273 end loop; 9274 end; 9275 end if; 9276 9277 -- Find entity of actual. If the actual is an attribute reference, it 9278 -- cannot be resolved here (its formal is missing) but is handled 9279 -- instead in Attribute_Renaming. If the actual is overloaded, it is 9280 -- fully resolved subsequently, when the renaming declaration for the 9281 -- formal is analyzed. If it is an explicit dereference, resolve the 9282 -- prefix but not the actual itself, to prevent interpretation as call. 9283 9284 if Present (Actual) then 9285 Loc := Sloc (Actual); 9286 Set_Sloc (New_Spec, Loc); 9287 9288 if Nkind (Actual) = N_Operator_Symbol then 9289 Find_Direct_Name (Actual); 9290 9291 elsif Nkind (Actual) = N_Explicit_Dereference then 9292 Analyze (Prefix (Actual)); 9293 9294 elsif Nkind (Actual) /= N_Attribute_Reference then 9295 Analyze (Actual); 9296 end if; 9297 9298 Valid_Actual_Subprogram (Actual); 9299 Nam := Actual; 9300 9301 elsif Present (Default_Name (Formal)) then 9302 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 9303 N_Selected_Component, 9304 N_Indexed_Component, 9305 N_Character_Literal) 9306 and then Present (Entity (Default_Name (Formal))) 9307 then 9308 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 9309 else 9310 Nam := New_Copy (Default_Name (Formal)); 9311 Set_Sloc (Nam, Loc); 9312 end if; 9313 9314 elsif Box_Present (Formal) then 9315 9316 -- Actual is resolved at the point of instantiation. Create an 9317 -- identifier or operator with the same name as the formal. 9318 9319 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 9320 Nam := Make_Operator_Symbol (Loc, 9321 Chars => Chars (Formal_Sub), 9322 Strval => No_String); 9323 else 9324 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 9325 end if; 9326 9327 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 9328 and then Null_Present (Specification (Formal)) 9329 then 9330 -- Generate null body for procedure, for use in the instance 9331 9332 Decl_Node := 9333 Make_Subprogram_Body (Loc, 9334 Specification => New_Spec, 9335 Declarations => New_List, 9336 Handled_Statement_Sequence => 9337 Make_Handled_Sequence_Of_Statements (Loc, 9338 Statements => New_List (Make_Null_Statement (Loc)))); 9339 9340 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 9341 return Decl_Node; 9342 9343 else 9344 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 9345 Error_Msg_NE 9346 ("missing actual&", Instantiation_Node, Formal_Sub); 9347 Error_Msg_NE 9348 ("\in instantiation of & declared#", 9349 Instantiation_Node, Scope (Analyzed_S)); 9350 Abandon_Instantiation (Instantiation_Node); 9351 end if; 9352 9353 Decl_Node := 9354 Make_Subprogram_Renaming_Declaration (Loc, 9355 Specification => New_Spec, 9356 Name => Nam); 9357 9358 -- If we do not have an actual and the formal specified <> then set to 9359 -- get proper default. 9360 9361 if No (Actual) and then Box_Present (Formal) then 9362 Set_From_Default (Decl_Node); 9363 end if; 9364 9365 -- Gather possible interpretations for the actual before analyzing the 9366 -- instance. If overloaded, it will be resolved when analyzing the 9367 -- renaming declaration. 9368 9369 if Box_Present (Formal) 9370 and then No (Actual) 9371 then 9372 Analyze (Nam); 9373 9374 if Is_Child_Unit (Scope (Analyzed_S)) 9375 and then Present (Entity (Nam)) 9376 then 9377 if not Is_Overloaded (Nam) then 9378 if From_Parent_Scope (Entity (Nam)) then 9379 Set_Is_Immediately_Visible (Entity (Nam), False); 9380 Set_Entity (Nam, Empty); 9381 Set_Etype (Nam, Empty); 9382 9383 Analyze (Nam); 9384 Set_Is_Immediately_Visible (Entity (Nam)); 9385 end if; 9386 9387 else 9388 declare 9389 I : Interp_Index; 9390 It : Interp; 9391 9392 begin 9393 Get_First_Interp (Nam, I, It); 9394 while Present (It.Nam) loop 9395 if From_Parent_Scope (It.Nam) then 9396 Remove_Interp (I); 9397 end if; 9398 9399 Get_Next_Interp (I, It); 9400 end loop; 9401 end; 9402 end if; 9403 end if; 9404 end if; 9405 9406 -- The generic instantiation freezes the actual. This can only be done 9407 -- once the actual is resolved, in the analysis of the renaming 9408 -- declaration. To make the formal subprogram entity available, we set 9409 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 9410 -- This is also needed in Analyze_Subprogram_Renaming for the processing 9411 -- of formal abstract subprograms. 9412 9413 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 9414 9415 -- We cannot analyze the renaming declaration, and thus find the actual, 9416 -- until all the actuals are assembled in the instance. For subsequent 9417 -- checks of other actuals, indicate the node that will hold the 9418 -- instance of this formal. 9419 9420 Set_Instance_Of (Analyzed_S, Nam); 9421 9422 if Nkind (Actual) = N_Selected_Component 9423 and then Is_Task_Type (Etype (Prefix (Actual))) 9424 and then not Is_Frozen (Etype (Prefix (Actual))) 9425 then 9426 -- The renaming declaration will create a body, which must appear 9427 -- outside of the instantiation, We move the renaming declaration 9428 -- out of the instance, and create an additional renaming inside, 9429 -- to prevent freezing anomalies. 9430 9431 declare 9432 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 9433 9434 begin 9435 Set_Defining_Unit_Name (New_Spec, Anon_Id); 9436 Insert_Before (Instantiation_Node, Decl_Node); 9437 Analyze (Decl_Node); 9438 9439 -- Now create renaming within the instance 9440 9441 Decl_Node := 9442 Make_Subprogram_Renaming_Declaration (Loc, 9443 Specification => New_Copy_Tree (New_Spec), 9444 Name => New_Occurrence_Of (Anon_Id, Loc)); 9445 9446 Set_Defining_Unit_Name (Specification (Decl_Node), 9447 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 9448 end; 9449 end if; 9450 9451 return Decl_Node; 9452 end Instantiate_Formal_Subprogram; 9453 9454 ------------------------ 9455 -- Instantiate_Object -- 9456 ------------------------ 9457 9458 function Instantiate_Object 9459 (Formal : Node_Id; 9460 Actual : Node_Id; 9461 Analyzed_Formal : Node_Id) return List_Id 9462 is 9463 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 9464 A_Gen_Obj : constant Entity_Id := 9465 Defining_Identifier (Analyzed_Formal); 9466 Acc_Def : Node_Id := Empty; 9467 Act_Assoc : constant Node_Id := Parent (Actual); 9468 Actual_Decl : Node_Id := Empty; 9469 Decl_Node : Node_Id; 9470 Def : Node_Id; 9471 Ftyp : Entity_Id; 9472 List : constant List_Id := New_List; 9473 Loc : constant Source_Ptr := Sloc (Actual); 9474 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 9475 Subt_Decl : Node_Id := Empty; 9476 Subt_Mark : Node_Id := Empty; 9477 9478 begin 9479 if Present (Subtype_Mark (Formal)) then 9480 Subt_Mark := Subtype_Mark (Formal); 9481 else 9482 Check_Access_Definition (Formal); 9483 Acc_Def := Access_Definition (Formal); 9484 end if; 9485 9486 -- Sloc for error message on missing actual 9487 9488 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 9489 9490 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 9491 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 9492 end if; 9493 9494 Set_Parent (List, Parent (Actual)); 9495 9496 -- OUT present 9497 9498 if Out_Present (Formal) then 9499 9500 -- An IN OUT generic actual must be a name. The instantiation is a 9501 -- renaming declaration. The actual is the name being renamed. We 9502 -- use the actual directly, rather than a copy, because it is not 9503 -- used further in the list of actuals, and because a copy or a use 9504 -- of relocate_node is incorrect if the instance is nested within a 9505 -- generic. In order to simplify ASIS searches, the Generic_Parent 9506 -- field links the declaration to the generic association. 9507 9508 if No (Actual) then 9509 Error_Msg_NE 9510 ("missing actual&", 9511 Instantiation_Node, Gen_Obj); 9512 Error_Msg_NE 9513 ("\in instantiation of & declared#", 9514 Instantiation_Node, Scope (A_Gen_Obj)); 9515 Abandon_Instantiation (Instantiation_Node); 9516 end if; 9517 9518 if Present (Subt_Mark) then 9519 Decl_Node := 9520 Make_Object_Renaming_Declaration (Loc, 9521 Defining_Identifier => New_Copy (Gen_Obj), 9522 Subtype_Mark => New_Copy_Tree (Subt_Mark), 9523 Name => Actual); 9524 9525 else pragma Assert (Present (Acc_Def)); 9526 Decl_Node := 9527 Make_Object_Renaming_Declaration (Loc, 9528 Defining_Identifier => New_Copy (Gen_Obj), 9529 Access_Definition => New_Copy_Tree (Acc_Def), 9530 Name => Actual); 9531 end if; 9532 9533 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 9534 9535 -- The analysis of the actual may produce Insert_Action nodes, so 9536 -- the declaration must have a context in which to attach them. 9537 9538 Append (Decl_Node, List); 9539 Analyze (Actual); 9540 9541 -- Return if the analysis of the actual reported some error 9542 9543 if Etype (Actual) = Any_Type then 9544 return List; 9545 end if; 9546 9547 -- This check is performed here because Analyze_Object_Renaming will 9548 -- not check it when Comes_From_Source is False. Note though that the 9549 -- check for the actual being the name of an object will be performed 9550 -- in Analyze_Object_Renaming. 9551 9552 if Is_Object_Reference (Actual) 9553 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 9554 then 9555 Error_Msg_N 9556 ("illegal discriminant-dependent component for in out parameter", 9557 Actual); 9558 end if; 9559 9560 -- The actual has to be resolved in order to check that it is a 9561 -- variable (due to cases such as F (1), where F returns access to an 9562 -- array, and for overloaded prefixes). 9563 9564 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 9565 9566 -- If the type of the formal is not itself a formal, and the 9567 -- current unit is a child unit, the formal type must be declared 9568 -- in a parent, and must be retrieved by visibility. 9569 9570 if Ftyp = Orig_Ftyp 9571 and then Is_Generic_Unit (Scope (Ftyp)) 9572 and then Is_Child_Unit (Scope (A_Gen_Obj)) 9573 then 9574 declare 9575 Temp : constant Node_Id := 9576 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 9577 begin 9578 Set_Entity (Temp, Empty); 9579 Find_Type (Temp); 9580 Ftyp := Entity (Temp); 9581 end; 9582 end if; 9583 9584 if Is_Private_Type (Ftyp) 9585 and then not Is_Private_Type (Etype (Actual)) 9586 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 9587 or else Base_Type (Etype (Actual)) = Ftyp) 9588 then 9589 -- If the actual has the type of the full view of the formal, or 9590 -- else a non-private subtype of the formal, then the visibility 9591 -- of the formal type has changed. Add to the actuals a subtype 9592 -- declaration that will force the exchange of views in the body 9593 -- of the instance as well. 9594 9595 Subt_Decl := 9596 Make_Subtype_Declaration (Loc, 9597 Defining_Identifier => Make_Temporary (Loc, 'P'), 9598 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 9599 9600 Prepend (Subt_Decl, List); 9601 9602 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 9603 Exchange_Declarations (Ftyp); 9604 end if; 9605 9606 Resolve (Actual, Ftyp); 9607 9608 if not Denotes_Variable (Actual) then 9609 Error_Msg_NE 9610 ("actual for& must be a variable", Actual, Gen_Obj); 9611 9612 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 9613 9614 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 9615 -- the type of the actual shall resolve to a specific anonymous 9616 -- access type. 9617 9618 if Ada_Version < Ada_2005 9619 or else 9620 Ekind (Base_Type (Ftyp)) /= 9621 E_Anonymous_Access_Type 9622 or else 9623 Ekind (Base_Type (Etype (Actual))) /= 9624 E_Anonymous_Access_Type 9625 then 9626 Error_Msg_NE ("type of actual does not match type of&", 9627 Actual, Gen_Obj); 9628 end if; 9629 end if; 9630 9631 Note_Possible_Modification (Actual, Sure => True); 9632 9633 -- Check for instantiation of atomic/volatile actual for 9634 -- non-atomic/volatile formal (RM C.6 (12)). 9635 9636 if Is_Atomic_Object (Actual) 9637 and then not Is_Atomic (Orig_Ftyp) 9638 then 9639 Error_Msg_N 9640 ("cannot instantiate non-atomic formal object " & 9641 "with atomic actual", Actual); 9642 9643 elsif Is_Volatile_Object (Actual) 9644 and then not Is_Volatile (Orig_Ftyp) 9645 then 9646 Error_Msg_N 9647 ("cannot instantiate non-volatile formal object " & 9648 "with volatile actual", Actual); 9649 end if; 9650 9651 -- Formal in-parameter 9652 9653 else 9654 -- The instantiation of a generic formal in-parameter is constant 9655 -- declaration. The actual is the expression for that declaration. 9656 9657 if Present (Actual) then 9658 if Present (Subt_Mark) then 9659 Def := Subt_Mark; 9660 else pragma Assert (Present (Acc_Def)); 9661 Def := Acc_Def; 9662 end if; 9663 9664 Decl_Node := 9665 Make_Object_Declaration (Loc, 9666 Defining_Identifier => New_Copy (Gen_Obj), 9667 Constant_Present => True, 9668 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9669 Object_Definition => New_Copy_Tree (Def), 9670 Expression => Actual); 9671 9672 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 9673 9674 -- A generic formal object of a tagged type is defined to be 9675 -- aliased so the new constant must also be treated as aliased. 9676 9677 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 9678 Set_Aliased_Present (Decl_Node); 9679 end if; 9680 9681 Append (Decl_Node, List); 9682 9683 -- No need to repeat (pre-)analysis of some expression nodes 9684 -- already handled in Preanalyze_Actuals. 9685 9686 if Nkind (Actual) /= N_Allocator then 9687 Analyze (Actual); 9688 9689 -- Return if the analysis of the actual reported some error 9690 9691 if Etype (Actual) = Any_Type then 9692 return List; 9693 end if; 9694 end if; 9695 9696 declare 9697 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 9698 Typ : Entity_Id; 9699 9700 begin 9701 Typ := Get_Instance_Of (Formal_Type); 9702 9703 Freeze_Before (Instantiation_Node, Typ); 9704 9705 -- If the actual is an aggregate, perform name resolution on 9706 -- its components (the analysis of an aggregate does not do it) 9707 -- to capture local names that may be hidden if the generic is 9708 -- a child unit. 9709 9710 if Nkind (Actual) = N_Aggregate then 9711 Preanalyze_And_Resolve (Actual, Typ); 9712 end if; 9713 9714 if Is_Limited_Type (Typ) 9715 and then not OK_For_Limited_Init (Typ, Actual) 9716 then 9717 Error_Msg_N 9718 ("initialization not allowed for limited types", Actual); 9719 Explain_Limited_Type (Typ, Actual); 9720 end if; 9721 end; 9722 9723 elsif Present (Default_Expression (Formal)) then 9724 9725 -- Use default to construct declaration 9726 9727 if Present (Subt_Mark) then 9728 Def := Subt_Mark; 9729 else pragma Assert (Present (Acc_Def)); 9730 Def := Acc_Def; 9731 end if; 9732 9733 Decl_Node := 9734 Make_Object_Declaration (Sloc (Formal), 9735 Defining_Identifier => New_Copy (Gen_Obj), 9736 Constant_Present => True, 9737 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9738 Object_Definition => New_Copy (Def), 9739 Expression => New_Copy_Tree 9740 (Default_Expression (Formal))); 9741 9742 Append (Decl_Node, List); 9743 Set_Analyzed (Expression (Decl_Node), False); 9744 9745 else 9746 Error_Msg_NE 9747 ("missing actual&", 9748 Instantiation_Node, Gen_Obj); 9749 Error_Msg_NE ("\in instantiation of & declared#", 9750 Instantiation_Node, Scope (A_Gen_Obj)); 9751 9752 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 9753 9754 -- Create dummy constant declaration so that instance can be 9755 -- analyzed, to minimize cascaded visibility errors. 9756 9757 if Present (Subt_Mark) then 9758 Def := Subt_Mark; 9759 else pragma Assert (Present (Acc_Def)); 9760 Def := Acc_Def; 9761 end if; 9762 9763 Decl_Node := 9764 Make_Object_Declaration (Loc, 9765 Defining_Identifier => New_Copy (Gen_Obj), 9766 Constant_Present => True, 9767 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9768 Object_Definition => New_Copy (Def), 9769 Expression => 9770 Make_Attribute_Reference (Sloc (Gen_Obj), 9771 Attribute_Name => Name_First, 9772 Prefix => New_Copy (Def))); 9773 9774 Append (Decl_Node, List); 9775 9776 else 9777 Abandon_Instantiation (Instantiation_Node); 9778 end if; 9779 end if; 9780 end if; 9781 9782 if Nkind (Actual) in N_Has_Entity then 9783 Actual_Decl := Parent (Entity (Actual)); 9784 end if; 9785 9786 -- Ada 2005 (AI-423): For a formal object declaration with a null 9787 -- exclusion or an access definition that has a null exclusion: If the 9788 -- actual matching the formal object declaration denotes a generic 9789 -- formal object of another generic unit G, and the instantiation 9790 -- containing the actual occurs within the body of G or within the body 9791 -- of a generic unit declared within the declarative region of G, then 9792 -- the declaration of the formal object of G must have a null exclusion. 9793 -- Otherwise, the subtype of the actual matching the formal object 9794 -- declaration shall exclude null. 9795 9796 if Ada_Version >= Ada_2005 9797 and then Present (Actual_Decl) 9798 and then 9799 Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 9800 N_Object_Declaration) 9801 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 9802 and then not Has_Null_Exclusion (Actual_Decl) 9803 and then Has_Null_Exclusion (Analyzed_Formal) 9804 then 9805 Error_Msg_Sloc := Sloc (Analyzed_Formal); 9806 Error_Msg_N 9807 ("actual must exclude null to match generic formal#", Actual); 9808 end if; 9809 9810 return List; 9811 end Instantiate_Object; 9812 9813 ------------------------------ 9814 -- Instantiate_Package_Body -- 9815 ------------------------------ 9816 9817 procedure Instantiate_Package_Body 9818 (Body_Info : Pending_Body_Info; 9819 Inlined_Body : Boolean := False; 9820 Body_Optional : Boolean := False) 9821 is 9822 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 9823 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 9824 Loc : constant Source_Ptr := Sloc (Inst_Node); 9825 9826 Gen_Id : constant Node_Id := Name (Inst_Node); 9827 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 9828 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 9829 Act_Spec : constant Node_Id := Specification (Act_Decl); 9830 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); 9831 9832 Act_Body_Name : Node_Id; 9833 Gen_Body : Node_Id; 9834 Gen_Body_Id : Node_Id; 9835 Act_Body : Node_Id; 9836 Act_Body_Id : Entity_Id; 9837 9838 Parent_Installed : Boolean := False; 9839 Save_Style_Check : constant Boolean := Style_Check; 9840 9841 Par_Ent : Entity_Id := Empty; 9842 Par_Vis : Boolean := False; 9843 9844 Vis_Prims_List : Elist_Id := No_Elist; 9845 -- List of primitives made temporarily visible in the instantiation 9846 -- to match the visibility of the formal type 9847 9848 begin 9849 Gen_Body_Id := Corresponding_Body (Gen_Decl); 9850 9851 -- The instance body may already have been processed, as the parent of 9852 -- another instance that is inlined (Load_Parent_Of_Generic). 9853 9854 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 9855 return; 9856 end if; 9857 9858 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 9859 9860 -- Re-establish the state of information on which checks are suppressed. 9861 -- This information was set in Body_Info at the point of instantiation, 9862 -- and now we restore it so that the instance is compiled using the 9863 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). 9864 9865 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 9866 Scope_Suppress := Body_Info.Scope_Suppress; 9867 Opt.Ada_Version := Body_Info.Version; 9868 9869 if No (Gen_Body_Id) then 9870 Load_Parent_Of_Generic 9871 (Inst_Node, Specification (Gen_Decl), Body_Optional); 9872 Gen_Body_Id := Corresponding_Body (Gen_Decl); 9873 end if; 9874 9875 -- Establish global variable for sloc adjustment and for error recovery 9876 9877 Instantiation_Node := Inst_Node; 9878 9879 if Present (Gen_Body_Id) then 9880 Save_Env (Gen_Unit, Act_Decl_Id); 9881 Style_Check := False; 9882 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 9883 9884 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 9885 9886 Create_Instantiation_Source 9887 (Inst_Node, Gen_Body_Id, False, S_Adjustment); 9888 9889 Act_Body := 9890 Copy_Generic_Node 9891 (Original_Node (Gen_Body), Empty, Instantiating => True); 9892 9893 -- Build new name (possibly qualified) for body declaration 9894 9895 Act_Body_Id := New_Copy (Act_Decl_Id); 9896 9897 -- Some attributes of spec entity are not inherited by body entity 9898 9899 Set_Handler_Records (Act_Body_Id, No_List); 9900 9901 if Nkind (Defining_Unit_Name (Act_Spec)) = 9902 N_Defining_Program_Unit_Name 9903 then 9904 Act_Body_Name := 9905 Make_Defining_Program_Unit_Name (Loc, 9906 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 9907 Defining_Identifier => Act_Body_Id); 9908 else 9909 Act_Body_Name := Act_Body_Id; 9910 end if; 9911 9912 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 9913 9914 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 9915 Check_Generic_Actuals (Act_Decl_Id, False); 9916 9917 -- Install primitives hidden at the point of the instantiation but 9918 -- visible when processing the generic formals 9919 9920 declare 9921 E : Entity_Id; 9922 9923 begin 9924 E := First_Entity (Act_Decl_Id); 9925 while Present (E) loop 9926 if Is_Type (E) 9927 and then Is_Generic_Actual_Type (E) 9928 and then Is_Tagged_Type (E) 9929 then 9930 Install_Hidden_Primitives 9931 (Prims_List => Vis_Prims_List, 9932 Gen_T => Generic_Parent_Type (Parent (E)), 9933 Act_T => E); 9934 end if; 9935 9936 Next_Entity (E); 9937 end loop; 9938 end; 9939 9940 -- If it is a child unit, make the parent instance (which is an 9941 -- instance of the parent of the generic) visible. The parent 9942 -- instance is the prefix of the name of the generic unit. 9943 9944 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 9945 and then Nkind (Gen_Id) = N_Expanded_Name 9946 then 9947 Par_Ent := Entity (Prefix (Gen_Id)); 9948 Par_Vis := Is_Immediately_Visible (Par_Ent); 9949 Install_Parent (Par_Ent, In_Body => True); 9950 Parent_Installed := True; 9951 9952 elsif Is_Child_Unit (Gen_Unit) then 9953 Par_Ent := Scope (Gen_Unit); 9954 Par_Vis := Is_Immediately_Visible (Par_Ent); 9955 Install_Parent (Par_Ent, In_Body => True); 9956 Parent_Installed := True; 9957 end if; 9958 9959 -- If the instantiation is a library unit, and this is the main unit, 9960 -- then build the resulting compilation unit nodes for the instance. 9961 -- If this is a compilation unit but it is not the main unit, then it 9962 -- is the body of a unit in the context, that is being compiled 9963 -- because it is encloses some inlined unit or another generic unit 9964 -- being instantiated. In that case, this body is not part of the 9965 -- current compilation, and is not attached to the tree, but its 9966 -- parent must be set for analysis. 9967 9968 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 9969 9970 -- Replace instance node with body of instance, and create new 9971 -- node for corresponding instance declaration. 9972 9973 Build_Instance_Compilation_Unit_Nodes 9974 (Inst_Node, Act_Body, Act_Decl); 9975 Analyze (Inst_Node); 9976 9977 if Parent (Inst_Node) = Cunit (Main_Unit) then 9978 9979 -- If the instance is a child unit itself, then set the scope 9980 -- of the expanded body to be the parent of the instantiation 9981 -- (ensuring that the fully qualified name will be generated 9982 -- for the elaboration subprogram). 9983 9984 if Nkind (Defining_Unit_Name (Act_Spec)) = 9985 N_Defining_Program_Unit_Name 9986 then 9987 Set_Scope 9988 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 9989 end if; 9990 end if; 9991 9992 -- Case where instantiation is not a library unit 9993 9994 else 9995 -- If this is an early instantiation, i.e. appears textually 9996 -- before the corresponding body and must be elaborated first, 9997 -- indicate that the body instance is to be delayed. 9998 9999 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 10000 10001 -- Now analyze the body. We turn off all checks if this is an 10002 -- internal unit, since there is no reason to have checks on for 10003 -- any predefined run-time library code. All such code is designed 10004 -- to be compiled with checks off. 10005 10006 -- Note that we do NOT apply this criterion to children of GNAT 10007 -- (or on VMS, children of DEC). The latter units must suppress 10008 -- checks explicitly if this is needed. 10009 10010 if Is_Predefined_File_Name 10011 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 10012 then 10013 Analyze (Act_Body, Suppress => All_Checks); 10014 else 10015 Analyze (Act_Body); 10016 end if; 10017 end if; 10018 10019 Inherit_Context (Gen_Body, Inst_Node); 10020 10021 -- Remove the parent instances if they have been placed on the scope 10022 -- stack to compile the body. 10023 10024 if Parent_Installed then 10025 Remove_Parent (In_Body => True); 10026 10027 -- Restore the previous visibility of the parent 10028 10029 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 10030 end if; 10031 10032 Restore_Hidden_Primitives (Vis_Prims_List); 10033 Restore_Private_Views (Act_Decl_Id); 10034 10035 -- Remove the current unit from visibility if this is an instance 10036 -- that is not elaborated on the fly for inlining purposes. 10037 10038 if not Inlined_Body then 10039 Set_Is_Immediately_Visible (Act_Decl_Id, False); 10040 end if; 10041 10042 Restore_Env; 10043 Style_Check := Save_Style_Check; 10044 10045 -- If we have no body, and the unit requires a body, then complain. This 10046 -- complaint is suppressed if we have detected other errors (since a 10047 -- common reason for missing the body is that it had errors). 10048 -- In CodePeer mode, a warning has been emitted already, no need for 10049 -- further messages. 10050 10051 elsif Unit_Requires_Body (Gen_Unit) 10052 and then not Body_Optional 10053 then 10054 if CodePeer_Mode then 10055 null; 10056 10057 elsif Serious_Errors_Detected = 0 then 10058 Error_Msg_NE 10059 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 10060 10061 -- Don't attempt to perform any cleanup actions if some other error 10062 -- was already detected, since this can cause blowups. 10063 10064 else 10065 return; 10066 end if; 10067 10068 -- Case of package that does not need a body 10069 10070 else 10071 -- If the instantiation of the declaration is a library unit, rewrite 10072 -- the original package instantiation as a package declaration in the 10073 -- compilation unit node. 10074 10075 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10076 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 10077 Rewrite (Inst_Node, Act_Decl); 10078 10079 -- Generate elaboration entity, in case spec has elaboration code. 10080 -- This cannot be done when the instance is analyzed, because it 10081 -- is not known yet whether the body exists. 10082 10083 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 10084 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 10085 10086 -- If the instantiation is not a library unit, then append the 10087 -- declaration to the list of implicitly generated entities, unless 10088 -- it is already a list member which means that it was already 10089 -- processed 10090 10091 elsif not Is_List_Member (Act_Decl) then 10092 Mark_Rewrite_Insertion (Act_Decl); 10093 Insert_Before (Inst_Node, Act_Decl); 10094 end if; 10095 end if; 10096 10097 Expander_Mode_Restore; 10098 end Instantiate_Package_Body; 10099 10100 --------------------------------- 10101 -- Instantiate_Subprogram_Body -- 10102 --------------------------------- 10103 10104 procedure Instantiate_Subprogram_Body 10105 (Body_Info : Pending_Body_Info; 10106 Body_Optional : Boolean := False) 10107 is 10108 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 10109 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 10110 Loc : constant Source_Ptr := Sloc (Inst_Node); 10111 Gen_Id : constant Node_Id := Name (Inst_Node); 10112 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 10113 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 10114 Anon_Id : constant Entity_Id := 10115 Defining_Unit_Name (Specification (Act_Decl)); 10116 Pack_Id : constant Entity_Id := 10117 Defining_Unit_Name (Parent (Act_Decl)); 10118 Decls : List_Id; 10119 Gen_Body : Node_Id; 10120 Gen_Body_Id : Node_Id; 10121 Act_Body : Node_Id; 10122 Pack_Body : Node_Id; 10123 Prev_Formal : Entity_Id; 10124 Ret_Expr : Node_Id; 10125 Unit_Renaming : Node_Id; 10126 10127 Parent_Installed : Boolean := False; 10128 Save_Style_Check : constant Boolean := Style_Check; 10129 10130 Par_Ent : Entity_Id := Empty; 10131 Par_Vis : Boolean := False; 10132 10133 begin 10134 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10135 10136 -- Subprogram body may have been created already because of an inline 10137 -- pragma, or because of multiple elaborations of the enclosing package 10138 -- when several instances of the subprogram appear in the main unit. 10139 10140 if Present (Corresponding_Body (Act_Decl)) then 10141 return; 10142 end if; 10143 10144 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 10145 10146 -- Re-establish the state of information on which checks are suppressed. 10147 -- This information was set in Body_Info at the point of instantiation, 10148 -- and now we restore it so that the instance is compiled using the 10149 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). 10150 10151 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 10152 Scope_Suppress := Body_Info.Scope_Suppress; 10153 Opt.Ada_Version := Body_Info.Version; 10154 10155 if No (Gen_Body_Id) then 10156 10157 -- For imported generic subprogram, no body to compile, complete 10158 -- the spec entity appropriately. 10159 10160 if Is_Imported (Gen_Unit) then 10161 Set_Is_Imported (Anon_Id); 10162 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); 10163 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); 10164 Set_Convention (Anon_Id, Convention (Gen_Unit)); 10165 Set_Has_Completion (Anon_Id); 10166 return; 10167 10168 -- For other cases, compile the body 10169 10170 else 10171 Load_Parent_Of_Generic 10172 (Inst_Node, Specification (Gen_Decl), Body_Optional); 10173 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10174 end if; 10175 end if; 10176 10177 Instantiation_Node := Inst_Node; 10178 10179 if Present (Gen_Body_Id) then 10180 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 10181 10182 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 10183 10184 -- Either body is not present, or context is non-expanding, as 10185 -- when compiling a subunit. Mark the instance as completed, and 10186 -- diagnose a missing body when needed. 10187 10188 if Expander_Active 10189 and then Operating_Mode = Generate_Code 10190 then 10191 Error_Msg_N 10192 ("missing proper body for instantiation", Gen_Body); 10193 end if; 10194 10195 Set_Has_Completion (Anon_Id); 10196 return; 10197 end if; 10198 10199 Save_Env (Gen_Unit, Anon_Id); 10200 Style_Check := False; 10201 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 10202 Create_Instantiation_Source 10203 (Inst_Node, 10204 Gen_Body_Id, 10205 False, 10206 S_Adjustment); 10207 10208 Act_Body := 10209 Copy_Generic_Node 10210 (Original_Node (Gen_Body), Empty, Instantiating => True); 10211 10212 -- Create proper defining name for the body, to correspond to 10213 -- the one in the spec. 10214 10215 Set_Defining_Unit_Name (Specification (Act_Body), 10216 Make_Defining_Identifier 10217 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id))); 10218 Set_Corresponding_Spec (Act_Body, Anon_Id); 10219 Set_Has_Completion (Anon_Id); 10220 Check_Generic_Actuals (Pack_Id, False); 10221 10222 -- Generate a reference to link the visible subprogram instance to 10223 -- the generic body, which for navigation purposes is the only 10224 -- available source for the instance. 10225 10226 Generate_Reference 10227 (Related_Instance (Pack_Id), 10228 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 10229 10230 -- If it is a child unit, make the parent instance (which is an 10231 -- instance of the parent of the generic) visible. The parent 10232 -- instance is the prefix of the name of the generic unit. 10233 10234 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 10235 and then Nkind (Gen_Id) = N_Expanded_Name 10236 then 10237 Par_Ent := Entity (Prefix (Gen_Id)); 10238 Par_Vis := Is_Immediately_Visible (Par_Ent); 10239 Install_Parent (Par_Ent, In_Body => True); 10240 Parent_Installed := True; 10241 10242 elsif Is_Child_Unit (Gen_Unit) then 10243 Par_Ent := Scope (Gen_Unit); 10244 Par_Vis := Is_Immediately_Visible (Par_Ent); 10245 Install_Parent (Par_Ent, In_Body => True); 10246 Parent_Installed := True; 10247 end if; 10248 10249 -- Inside its body, a reference to the generic unit is a reference 10250 -- to the instance. The corresponding renaming is the first 10251 -- declaration in the body. 10252 10253 Unit_Renaming := 10254 Make_Subprogram_Renaming_Declaration (Loc, 10255 Specification => 10256 Copy_Generic_Node ( 10257 Specification (Original_Node (Gen_Body)), 10258 Empty, 10259 Instantiating => True), 10260 Name => New_Occurrence_Of (Anon_Id, Loc)); 10261 10262 -- If there is a formal subprogram with the same name as the unit 10263 -- itself, do not add this renaming declaration. This is a temporary 10264 -- fix for one ACVC test. ??? 10265 10266 Prev_Formal := First_Entity (Pack_Id); 10267 while Present (Prev_Formal) loop 10268 if Chars (Prev_Formal) = Chars (Gen_Unit) 10269 and then Is_Overloadable (Prev_Formal) 10270 then 10271 exit; 10272 end if; 10273 10274 Next_Entity (Prev_Formal); 10275 end loop; 10276 10277 if Present (Prev_Formal) then 10278 Decls := New_List (Act_Body); 10279 else 10280 Decls := New_List (Unit_Renaming, Act_Body); 10281 end if; 10282 10283 -- The subprogram body is placed in the body of a dummy package body, 10284 -- whose spec contains the subprogram declaration as well as the 10285 -- renaming declarations for the generic parameters. 10286 10287 Pack_Body := Make_Package_Body (Loc, 10288 Defining_Unit_Name => New_Copy (Pack_Id), 10289 Declarations => Decls); 10290 10291 Set_Corresponding_Spec (Pack_Body, Pack_Id); 10292 10293 -- If the instantiation is a library unit, then build resulting 10294 -- compilation unit nodes for the instance. The declaration of 10295 -- the enclosing package is the grandparent of the subprogram 10296 -- declaration. First replace the instantiation node as the unit 10297 -- of the corresponding compilation. 10298 10299 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10300 if Parent (Inst_Node) = Cunit (Main_Unit) then 10301 Set_Unit (Parent (Inst_Node), Inst_Node); 10302 Build_Instance_Compilation_Unit_Nodes 10303 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 10304 Analyze (Inst_Node); 10305 else 10306 Set_Parent (Pack_Body, Parent (Inst_Node)); 10307 Analyze (Pack_Body); 10308 end if; 10309 10310 else 10311 Insert_Before (Inst_Node, Pack_Body); 10312 Mark_Rewrite_Insertion (Pack_Body); 10313 Analyze (Pack_Body); 10314 10315 if Expander_Active then 10316 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 10317 end if; 10318 end if; 10319 10320 Inherit_Context (Gen_Body, Inst_Node); 10321 10322 Restore_Private_Views (Pack_Id, False); 10323 10324 if Parent_Installed then 10325 Remove_Parent (In_Body => True); 10326 10327 -- Restore the previous visibility of the parent 10328 10329 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 10330 end if; 10331 10332 Restore_Env; 10333 Style_Check := Save_Style_Check; 10334 10335 -- Body not found. Error was emitted already. If there were no previous 10336 -- errors, this may be an instance whose scope is a premature instance. 10337 -- In that case we must insure that the (legal) program does raise 10338 -- program error if executed. We generate a subprogram body for this 10339 -- purpose. See DEC ac30vso. 10340 10341 -- Should not reference proprietary DEC tests in comments ??? 10342 10343 elsif Serious_Errors_Detected = 0 10344 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 10345 then 10346 if Body_Optional then 10347 return; 10348 10349 elsif Ekind (Anon_Id) = E_Procedure then 10350 Act_Body := 10351 Make_Subprogram_Body (Loc, 10352 Specification => 10353 Make_Procedure_Specification (Loc, 10354 Defining_Unit_Name => 10355 Make_Defining_Identifier (Loc, Chars (Anon_Id)), 10356 Parameter_Specifications => 10357 New_Copy_List 10358 (Parameter_Specifications (Parent (Anon_Id)))), 10359 10360 Declarations => Empty_List, 10361 Handled_Statement_Sequence => 10362 Make_Handled_Sequence_Of_Statements (Loc, 10363 Statements => 10364 New_List ( 10365 Make_Raise_Program_Error (Loc, 10366 Reason => 10367 PE_Access_Before_Elaboration)))); 10368 10369 else 10370 Ret_Expr := 10371 Make_Raise_Program_Error (Loc, 10372 Reason => PE_Access_Before_Elaboration); 10373 10374 Set_Etype (Ret_Expr, (Etype (Anon_Id))); 10375 Set_Analyzed (Ret_Expr); 10376 10377 Act_Body := 10378 Make_Subprogram_Body (Loc, 10379 Specification => 10380 Make_Function_Specification (Loc, 10381 Defining_Unit_Name => 10382 Make_Defining_Identifier (Loc, Chars (Anon_Id)), 10383 Parameter_Specifications => 10384 New_Copy_List 10385 (Parameter_Specifications (Parent (Anon_Id))), 10386 Result_Definition => 10387 New_Occurrence_Of (Etype (Anon_Id), Loc)), 10388 10389 Declarations => Empty_List, 10390 Handled_Statement_Sequence => 10391 Make_Handled_Sequence_Of_Statements (Loc, 10392 Statements => 10393 New_List 10394 (Make_Simple_Return_Statement (Loc, Ret_Expr)))); 10395 end if; 10396 10397 Pack_Body := Make_Package_Body (Loc, 10398 Defining_Unit_Name => New_Copy (Pack_Id), 10399 Declarations => New_List (Act_Body)); 10400 10401 Insert_After (Inst_Node, Pack_Body); 10402 Set_Corresponding_Spec (Pack_Body, Pack_Id); 10403 Analyze (Pack_Body); 10404 end if; 10405 10406 Expander_Mode_Restore; 10407 end Instantiate_Subprogram_Body; 10408 10409 ---------------------- 10410 -- Instantiate_Type -- 10411 ---------------------- 10412 10413 function Instantiate_Type 10414 (Formal : Node_Id; 10415 Actual : Node_Id; 10416 Analyzed_Formal : Node_Id; 10417 Actual_Decls : List_Id) return List_Id 10418 is 10419 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 10420 A_Gen_T : constant Entity_Id := 10421 Defining_Identifier (Analyzed_Formal); 10422 Ancestor : Entity_Id := Empty; 10423 Def : constant Node_Id := Formal_Type_Definition (Formal); 10424 Act_T : Entity_Id; 10425 Decl_Node : Node_Id; 10426 Decl_Nodes : List_Id; 10427 Loc : Source_Ptr; 10428 Subt : Entity_Id; 10429 10430 procedure Validate_Array_Type_Instance; 10431 procedure Validate_Access_Subprogram_Instance; 10432 procedure Validate_Access_Type_Instance; 10433 procedure Validate_Derived_Type_Instance; 10434 procedure Validate_Derived_Interface_Type_Instance; 10435 procedure Validate_Discriminated_Formal_Type; 10436 procedure Validate_Interface_Type_Instance; 10437 procedure Validate_Private_Type_Instance; 10438 procedure Validate_Incomplete_Type_Instance; 10439 -- These procedures perform validation tests for the named case. 10440 -- Validate_Discriminated_Formal_Type is shared by formal private 10441 -- types and Ada 2012 formal incomplete types. 10442 10443 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 10444 -- Check that base types are the same and that the subtypes match 10445 -- statically. Used in several of the above. 10446 10447 -------------------- 10448 -- Subtypes_Match -- 10449 -------------------- 10450 10451 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 10452 T : constant Entity_Id := Get_Instance_Of (Gen_T); 10453 10454 begin 10455 -- Some detailed comments would be useful here ??? 10456 10457 return ((Base_Type (T) = Act_T 10458 or else Base_Type (T) = Base_Type (Act_T)) 10459 and then Subtypes_Statically_Match (T, Act_T)) 10460 10461 or else (Is_Class_Wide_Type (Gen_T) 10462 and then Is_Class_Wide_Type (Act_T) 10463 and then Subtypes_Match 10464 (Get_Instance_Of (Root_Type (Gen_T)), 10465 Root_Type (Act_T))) 10466 10467 or else 10468 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 10469 E_Anonymous_Access_Type) 10470 and then Ekind (Act_T) = Ekind (Gen_T) 10471 and then Subtypes_Statically_Match 10472 (Designated_Type (Gen_T), Designated_Type (Act_T))); 10473 end Subtypes_Match; 10474 10475 ----------------------------------------- 10476 -- Validate_Access_Subprogram_Instance -- 10477 ----------------------------------------- 10478 10479 procedure Validate_Access_Subprogram_Instance is 10480 begin 10481 if not Is_Access_Type (Act_T) 10482 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 10483 then 10484 Error_Msg_NE 10485 ("expect access type in instantiation of &", Actual, Gen_T); 10486 Abandon_Instantiation (Actual); 10487 end if; 10488 10489 -- According to AI05-288, actuals for access_to_subprograms must be 10490 -- subtype conformant with the generic formal. Previous to AI05-288 10491 -- only mode conformance was required. 10492 10493 -- This is a binding interpretation that applies to previous versions 10494 -- of the language, but for now we retain the milder check in order 10495 -- to preserve ACATS tests. These will be protested eventually ??? 10496 10497 if Ada_Version < Ada_2012 then 10498 Check_Mode_Conformant 10499 (Designated_Type (Act_T), 10500 Designated_Type (A_Gen_T), 10501 Actual, 10502 Get_Inst => True); 10503 10504 else 10505 Check_Subtype_Conformant 10506 (Designated_Type (Act_T), 10507 Designated_Type (A_Gen_T), 10508 Actual, 10509 Get_Inst => True); 10510 end if; 10511 10512 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 10513 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 10514 Error_Msg_NE 10515 ("protected access type not allowed for formal &", 10516 Actual, Gen_T); 10517 end if; 10518 10519 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 10520 Error_Msg_NE 10521 ("expect protected access type for formal &", 10522 Actual, Gen_T); 10523 end if; 10524 end Validate_Access_Subprogram_Instance; 10525 10526 ----------------------------------- 10527 -- Validate_Access_Type_Instance -- 10528 ----------------------------------- 10529 10530 procedure Validate_Access_Type_Instance is 10531 Desig_Type : constant Entity_Id := 10532 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 10533 Desig_Act : Entity_Id; 10534 10535 begin 10536 if not Is_Access_Type (Act_T) then 10537 Error_Msg_NE 10538 ("expect access type in instantiation of &", Actual, Gen_T); 10539 Abandon_Instantiation (Actual); 10540 end if; 10541 10542 if Is_Access_Constant (A_Gen_T) then 10543 if not Is_Access_Constant (Act_T) then 10544 Error_Msg_N 10545 ("actual type must be access-to-constant type", Actual); 10546 Abandon_Instantiation (Actual); 10547 end if; 10548 else 10549 if Is_Access_Constant (Act_T) then 10550 Error_Msg_N 10551 ("actual type must be access-to-variable type", Actual); 10552 Abandon_Instantiation (Actual); 10553 10554 elsif Ekind (A_Gen_T) = E_General_Access_Type 10555 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 10556 then 10557 Error_Msg_N -- CODEFIX 10558 ("actual must be general access type!", Actual); 10559 Error_Msg_NE -- CODEFIX 10560 ("add ALL to }!", Actual, Act_T); 10561 Abandon_Instantiation (Actual); 10562 end if; 10563 end if; 10564 10565 -- The designated subtypes, that is to say the subtypes introduced 10566 -- by an access type declaration (and not by a subtype declaration) 10567 -- must match. 10568 10569 Desig_Act := Designated_Type (Base_Type (Act_T)); 10570 10571 -- The designated type may have been introduced through a limited_ 10572 -- with clause, in which case retrieve the non-limited view. This 10573 -- applies to incomplete types as well as to class-wide types. 10574 10575 if From_With_Type (Desig_Act) then 10576 Desig_Act := Available_View (Desig_Act); 10577 end if; 10578 10579 if not Subtypes_Match 10580 (Desig_Type, Desig_Act) then 10581 Error_Msg_NE 10582 ("designated type of actual does not match that of formal &", 10583 Actual, Gen_T); 10584 Abandon_Instantiation (Actual); 10585 10586 elsif Is_Access_Type (Designated_Type (Act_T)) 10587 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 10588 /= 10589 Is_Constrained (Designated_Type (Desig_Type)) 10590 then 10591 Error_Msg_NE 10592 ("designated type of actual does not match that of formal &", 10593 Actual, Gen_T); 10594 Abandon_Instantiation (Actual); 10595 end if; 10596 10597 -- Ada 2005: null-exclusion indicators of the two types must agree 10598 10599 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 10600 Error_Msg_NE 10601 ("non null exclusion of actual and formal & do not match", 10602 Actual, Gen_T); 10603 end if; 10604 end Validate_Access_Type_Instance; 10605 10606 ---------------------------------- 10607 -- Validate_Array_Type_Instance -- 10608 ---------------------------------- 10609 10610 procedure Validate_Array_Type_Instance is 10611 I1 : Node_Id; 10612 I2 : Node_Id; 10613 T2 : Entity_Id; 10614 10615 function Formal_Dimensions return Int; 10616 -- Count number of dimensions in array type formal 10617 10618 ----------------------- 10619 -- Formal_Dimensions -- 10620 ----------------------- 10621 10622 function Formal_Dimensions return Int is 10623 Num : Int := 0; 10624 Index : Node_Id; 10625 10626 begin 10627 if Nkind (Def) = N_Constrained_Array_Definition then 10628 Index := First (Discrete_Subtype_Definitions (Def)); 10629 else 10630 Index := First (Subtype_Marks (Def)); 10631 end if; 10632 10633 while Present (Index) loop 10634 Num := Num + 1; 10635 Next_Index (Index); 10636 end loop; 10637 10638 return Num; 10639 end Formal_Dimensions; 10640 10641 -- Start of processing for Validate_Array_Type_Instance 10642 10643 begin 10644 if not Is_Array_Type (Act_T) then 10645 Error_Msg_NE 10646 ("expect array type in instantiation of &", Actual, Gen_T); 10647 Abandon_Instantiation (Actual); 10648 10649 elsif Nkind (Def) = N_Constrained_Array_Definition then 10650 if not (Is_Constrained (Act_T)) then 10651 Error_Msg_NE 10652 ("expect constrained array in instantiation of &", 10653 Actual, Gen_T); 10654 Abandon_Instantiation (Actual); 10655 end if; 10656 10657 else 10658 if Is_Constrained (Act_T) then 10659 Error_Msg_NE 10660 ("expect unconstrained array in instantiation of &", 10661 Actual, Gen_T); 10662 Abandon_Instantiation (Actual); 10663 end if; 10664 end if; 10665 10666 if Formal_Dimensions /= Number_Dimensions (Act_T) then 10667 Error_Msg_NE 10668 ("dimensions of actual do not match formal &", Actual, Gen_T); 10669 Abandon_Instantiation (Actual); 10670 end if; 10671 10672 I1 := First_Index (A_Gen_T); 10673 I2 := First_Index (Act_T); 10674 for J in 1 .. Formal_Dimensions loop 10675 10676 -- If the indexes of the actual were given by a subtype_mark, 10677 -- the index was transformed into a range attribute. Retrieve 10678 -- the original type mark for checking. 10679 10680 if Is_Entity_Name (Original_Node (I2)) then 10681 T2 := Entity (Original_Node (I2)); 10682 else 10683 T2 := Etype (I2); 10684 end if; 10685 10686 if not Subtypes_Match 10687 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 10688 then 10689 Error_Msg_NE 10690 ("index types of actual do not match those of formal &", 10691 Actual, Gen_T); 10692 Abandon_Instantiation (Actual); 10693 end if; 10694 10695 Next_Index (I1); 10696 Next_Index (I2); 10697 end loop; 10698 10699 -- Check matching subtypes. Note that there are complex visibility 10700 -- issues when the generic is a child unit and some aspect of the 10701 -- generic type is declared in a parent unit of the generic. We do 10702 -- the test to handle this special case only after a direct check 10703 -- for static matching has failed. The case where both the component 10704 -- type and the array type are separate formals, and the component 10705 -- type is a private view may also require special checking in 10706 -- Subtypes_Match. 10707 10708 if Subtypes_Match 10709 (Component_Type (A_Gen_T), Component_Type (Act_T)) 10710 or else Subtypes_Match 10711 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 10712 Component_Type (Act_T)) 10713 then 10714 null; 10715 else 10716 Error_Msg_NE 10717 ("component subtype of actual does not match that of formal &", 10718 Actual, Gen_T); 10719 Abandon_Instantiation (Actual); 10720 end if; 10721 10722 if Has_Aliased_Components (A_Gen_T) 10723 and then not Has_Aliased_Components (Act_T) 10724 then 10725 Error_Msg_NE 10726 ("actual must have aliased components to match formal type &", 10727 Actual, Gen_T); 10728 end if; 10729 end Validate_Array_Type_Instance; 10730 10731 ----------------------------------------------- 10732 -- Validate_Derived_Interface_Type_Instance -- 10733 ----------------------------------------------- 10734 10735 procedure Validate_Derived_Interface_Type_Instance is 10736 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 10737 Elmt : Elmt_Id; 10738 10739 begin 10740 -- First apply interface instance checks 10741 10742 Validate_Interface_Type_Instance; 10743 10744 -- Verify that immediate parent interface is an ancestor of 10745 -- the actual. 10746 10747 if Present (Par) 10748 and then not Interface_Present_In_Ancestor (Act_T, Par) 10749 then 10750 Error_Msg_NE 10751 ("interface actual must include progenitor&", Actual, Par); 10752 end if; 10753 10754 -- Now verify that the actual includes all other ancestors of 10755 -- the formal. 10756 10757 Elmt := First_Elmt (Interfaces (A_Gen_T)); 10758 while Present (Elmt) loop 10759 if not Interface_Present_In_Ancestor 10760 (Act_T, Get_Instance_Of (Node (Elmt))) 10761 then 10762 Error_Msg_NE 10763 ("interface actual must include progenitor&", 10764 Actual, Node (Elmt)); 10765 end if; 10766 10767 Next_Elmt (Elmt); 10768 end loop; 10769 end Validate_Derived_Interface_Type_Instance; 10770 10771 ------------------------------------ 10772 -- Validate_Derived_Type_Instance -- 10773 ------------------------------------ 10774 10775 procedure Validate_Derived_Type_Instance is 10776 Actual_Discr : Entity_Id; 10777 Ancestor_Discr : Entity_Id; 10778 10779 begin 10780 -- If the parent type in the generic declaration is itself a previous 10781 -- formal type, then it is local to the generic and absent from the 10782 -- analyzed generic definition. In that case the ancestor is the 10783 -- instance of the formal (which must have been instantiated 10784 -- previously), unless the ancestor is itself a formal derived type. 10785 -- In this latter case (which is the subject of Corrigendum 8652/0038 10786 -- (AI-202) the ancestor of the formals is the ancestor of its 10787 -- parent. Otherwise, the analyzed generic carries the parent type. 10788 -- If the parent type is defined in a previous formal package, then 10789 -- the scope of that formal package is that of the generic type 10790 -- itself, and it has already been mapped into the corresponding type 10791 -- in the actual package. 10792 10793 -- Common case: parent type defined outside of the generic 10794 10795 if Is_Entity_Name (Subtype_Mark (Def)) 10796 and then Present (Entity (Subtype_Mark (Def))) 10797 then 10798 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 10799 10800 -- Check whether parent is defined in a previous formal package 10801 10802 elsif 10803 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 10804 then 10805 Ancestor := 10806 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 10807 10808 -- The type may be a local derivation, or a type extension of a 10809 -- previous formal, or of a formal of a parent package. 10810 10811 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 10812 or else 10813 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 10814 then 10815 -- Check whether the parent is another derived formal type in the 10816 -- same generic unit. 10817 10818 if Etype (A_Gen_T) /= A_Gen_T 10819 and then Is_Generic_Type (Etype (A_Gen_T)) 10820 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 10821 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 10822 then 10823 -- Locate ancestor of parent from the subtype declaration 10824 -- created for the actual. 10825 10826 declare 10827 Decl : Node_Id; 10828 10829 begin 10830 Decl := First (Actual_Decls); 10831 while Present (Decl) loop 10832 if Nkind (Decl) = N_Subtype_Declaration 10833 and then Chars (Defining_Identifier (Decl)) = 10834 Chars (Etype (A_Gen_T)) 10835 then 10836 Ancestor := Generic_Parent_Type (Decl); 10837 exit; 10838 else 10839 Next (Decl); 10840 end if; 10841 end loop; 10842 end; 10843 10844 pragma Assert (Present (Ancestor)); 10845 10846 -- The ancestor itself may be a previous formal that has been 10847 -- instantiated. 10848 10849 Ancestor := Get_Instance_Of (Ancestor); 10850 10851 else 10852 Ancestor := 10853 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 10854 end if; 10855 10856 -- An unusual case: the actual is a type declared in a parent unit, 10857 -- but is not a formal type so there is no instance_of for it. 10858 -- Retrieve it by analyzing the record extension. 10859 10860 elsif Is_Child_Unit (Scope (A_Gen_T)) 10861 and then In_Open_Scopes (Scope (Act_T)) 10862 and then Is_Generic_Instance (Scope (Act_T)) 10863 then 10864 Analyze (Subtype_Mark (Def)); 10865 Ancestor := Entity (Subtype_Mark (Def)); 10866 10867 else 10868 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 10869 end if; 10870 10871 -- If the formal derived type has pragma Preelaborable_Initialization 10872 -- then the actual type must have preelaborable initialization. 10873 10874 if Known_To_Have_Preelab_Init (A_Gen_T) 10875 and then not Has_Preelaborable_Initialization (Act_T) 10876 then 10877 Error_Msg_NE 10878 ("actual for & must have preelaborable initialization", 10879 Actual, Gen_T); 10880 end if; 10881 10882 -- Ada 2005 (AI-251) 10883 10884 if Ada_Version >= Ada_2005 10885 and then Is_Interface (Ancestor) 10886 then 10887 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 10888 Error_Msg_NE 10889 ("(Ada 2005) expected type implementing & in instantiation", 10890 Actual, Ancestor); 10891 end if; 10892 10893 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 10894 Error_Msg_NE 10895 ("expect type derived from & in instantiation", 10896 Actual, First_Subtype (Ancestor)); 10897 Abandon_Instantiation (Actual); 10898 end if; 10899 10900 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 10901 -- that the formal type declaration has been rewritten as a private 10902 -- extension. 10903 10904 if Ada_Version >= Ada_2005 10905 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 10906 and then Synchronized_Present (Parent (A_Gen_T)) 10907 then 10908 -- The actual must be a synchronized tagged type 10909 10910 if not Is_Tagged_Type (Act_T) then 10911 Error_Msg_N 10912 ("actual of synchronized type must be tagged", Actual); 10913 Abandon_Instantiation (Actual); 10914 10915 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 10916 and then Nkind (Type_Definition (Parent (Act_T))) = 10917 N_Derived_Type_Definition 10918 and then not Synchronized_Present (Type_Definition 10919 (Parent (Act_T))) 10920 then 10921 Error_Msg_N 10922 ("actual of synchronized type must be synchronized", Actual); 10923 Abandon_Instantiation (Actual); 10924 end if; 10925 end if; 10926 10927 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 10928 -- removes the second instance of the phrase "or allow pass by copy". 10929 10930 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then 10931 Error_Msg_N 10932 ("cannot have atomic actual type for non-atomic formal type", 10933 Actual); 10934 10935 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then 10936 Error_Msg_N 10937 ("cannot have volatile actual type for non-volatile formal type", 10938 Actual); 10939 end if; 10940 10941 -- It should not be necessary to check for unknown discriminants on 10942 -- Formal, but for some reason Has_Unknown_Discriminants is false for 10943 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This 10944 -- needs fixing. ??? 10945 10946 if not Is_Indefinite_Subtype (A_Gen_T) 10947 and then not Unknown_Discriminants_Present (Formal) 10948 and then Is_Indefinite_Subtype (Act_T) 10949 then 10950 Error_Msg_N 10951 ("actual subtype must be constrained", Actual); 10952 Abandon_Instantiation (Actual); 10953 end if; 10954 10955 if not Unknown_Discriminants_Present (Formal) then 10956 if Is_Constrained (Ancestor) then 10957 if not Is_Constrained (Act_T) then 10958 Error_Msg_N 10959 ("actual subtype must be constrained", Actual); 10960 Abandon_Instantiation (Actual); 10961 end if; 10962 10963 -- Ancestor is unconstrained, Check if generic formal and actual 10964 -- agree on constrainedness. The check only applies to array types 10965 -- and discriminated types. 10966 10967 elsif Is_Constrained (Act_T) then 10968 if Ekind (Ancestor) = E_Access_Type 10969 or else 10970 (not Is_Constrained (A_Gen_T) 10971 and then Is_Composite_Type (A_Gen_T)) 10972 then 10973 Error_Msg_N 10974 ("actual subtype must be unconstrained", Actual); 10975 Abandon_Instantiation (Actual); 10976 end if; 10977 10978 -- A class-wide type is only allowed if the formal has unknown 10979 -- discriminants. 10980 10981 elsif Is_Class_Wide_Type (Act_T) 10982 and then not Has_Unknown_Discriminants (Ancestor) 10983 then 10984 Error_Msg_NE 10985 ("actual for & cannot be a class-wide type", Actual, Gen_T); 10986 Abandon_Instantiation (Actual); 10987 10988 -- Otherwise, the formal and actual shall have the same number 10989 -- of discriminants and each discriminant of the actual must 10990 -- correspond to a discriminant of the formal. 10991 10992 elsif Has_Discriminants (Act_T) 10993 and then not Has_Unknown_Discriminants (Act_T) 10994 and then Has_Discriminants (Ancestor) 10995 then 10996 Actual_Discr := First_Discriminant (Act_T); 10997 Ancestor_Discr := First_Discriminant (Ancestor); 10998 while Present (Actual_Discr) 10999 and then Present (Ancestor_Discr) 11000 loop 11001 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 11002 No (Corresponding_Discriminant (Actual_Discr)) 11003 then 11004 Error_Msg_NE 11005 ("discriminant & does not correspond " & 11006 "to ancestor discriminant", Actual, Actual_Discr); 11007 Abandon_Instantiation (Actual); 11008 end if; 11009 11010 Next_Discriminant (Actual_Discr); 11011 Next_Discriminant (Ancestor_Discr); 11012 end loop; 11013 11014 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 11015 Error_Msg_NE 11016 ("actual for & must have same number of discriminants", 11017 Actual, Gen_T); 11018 Abandon_Instantiation (Actual); 11019 end if; 11020 11021 -- This case should be caught by the earlier check for 11022 -- constrainedness, but the check here is added for completeness. 11023 11024 elsif Has_Discriminants (Act_T) 11025 and then not Has_Unknown_Discriminants (Act_T) 11026 then 11027 Error_Msg_NE 11028 ("actual for & must not have discriminants", Actual, Gen_T); 11029 Abandon_Instantiation (Actual); 11030 11031 elsif Has_Discriminants (Ancestor) then 11032 Error_Msg_NE 11033 ("actual for & must have known discriminants", Actual, Gen_T); 11034 Abandon_Instantiation (Actual); 11035 end if; 11036 11037 if not Subtypes_Statically_Compatible (Act_T, Ancestor) then 11038 Error_Msg_N 11039 ("constraint on actual is incompatible with formal", Actual); 11040 Abandon_Instantiation (Actual); 11041 end if; 11042 end if; 11043 11044 -- If the formal and actual types are abstract, check that there 11045 -- are no abstract primitives of the actual type that correspond to 11046 -- nonabstract primitives of the formal type (second sentence of 11047 -- RM95-3.9.3(9)). 11048 11049 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 11050 Check_Abstract_Primitives : declare 11051 Gen_Prims : constant Elist_Id := 11052 Primitive_Operations (A_Gen_T); 11053 Gen_Elmt : Elmt_Id; 11054 Gen_Subp : Entity_Id; 11055 Anc_Subp : Entity_Id; 11056 Anc_Formal : Entity_Id; 11057 Anc_F_Type : Entity_Id; 11058 11059 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 11060 Act_Elmt : Elmt_Id; 11061 Act_Subp : Entity_Id; 11062 Act_Formal : Entity_Id; 11063 Act_F_Type : Entity_Id; 11064 11065 Subprograms_Correspond : Boolean; 11066 11067 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 11068 -- Returns true if T2 is derived directly or indirectly from 11069 -- T1, including derivations from interfaces. T1 and T2 are 11070 -- required to be specific tagged base types. 11071 11072 ------------------------ 11073 -- Is_Tagged_Ancestor -- 11074 ------------------------ 11075 11076 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 11077 is 11078 Intfc_Elmt : Elmt_Id; 11079 11080 begin 11081 -- The predicate is satisfied if the types are the same 11082 11083 if T1 = T2 then 11084 return True; 11085 11086 -- If we've reached the top of the derivation chain then 11087 -- we know that T1 is not an ancestor of T2. 11088 11089 elsif Etype (T2) = T2 then 11090 return False; 11091 11092 -- Proceed to check T2's immediate parent 11093 11094 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 11095 return True; 11096 11097 -- Finally, check to see if T1 is an ancestor of any of T2's 11098 -- progenitors. 11099 11100 else 11101 Intfc_Elmt := First_Elmt (Interfaces (T2)); 11102 while Present (Intfc_Elmt) loop 11103 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 11104 return True; 11105 end if; 11106 11107 Next_Elmt (Intfc_Elmt); 11108 end loop; 11109 end if; 11110 11111 return False; 11112 end Is_Tagged_Ancestor; 11113 11114 -- Start of processing for Check_Abstract_Primitives 11115 11116 begin 11117 -- Loop over all of the formal derived type's primitives 11118 11119 Gen_Elmt := First_Elmt (Gen_Prims); 11120 while Present (Gen_Elmt) loop 11121 Gen_Subp := Node (Gen_Elmt); 11122 11123 -- If the primitive of the formal is not abstract, then 11124 -- determine whether there is a corresponding primitive of 11125 -- the actual type that's abstract. 11126 11127 if not Is_Abstract_Subprogram (Gen_Subp) then 11128 Act_Elmt := First_Elmt (Act_Prims); 11129 while Present (Act_Elmt) loop 11130 Act_Subp := Node (Act_Elmt); 11131 11132 -- If we find an abstract primitive of the actual, 11133 -- then we need to test whether it corresponds to the 11134 -- subprogram from which the generic formal primitive 11135 -- is inherited. 11136 11137 if Is_Abstract_Subprogram (Act_Subp) then 11138 Anc_Subp := Alias (Gen_Subp); 11139 11140 -- Test whether we have a corresponding primitive 11141 -- by comparing names, kinds, formal types, and 11142 -- result types. 11143 11144 if Chars (Anc_Subp) = Chars (Act_Subp) 11145 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 11146 then 11147 Anc_Formal := First_Formal (Anc_Subp); 11148 Act_Formal := First_Formal (Act_Subp); 11149 while Present (Anc_Formal) 11150 and then Present (Act_Formal) 11151 loop 11152 Anc_F_Type := Etype (Anc_Formal); 11153 Act_F_Type := Etype (Act_Formal); 11154 11155 if Ekind (Anc_F_Type) 11156 = E_Anonymous_Access_Type 11157 then 11158 Anc_F_Type := Designated_Type (Anc_F_Type); 11159 11160 if Ekind (Act_F_Type) 11161 = E_Anonymous_Access_Type 11162 then 11163 Act_F_Type := 11164 Designated_Type (Act_F_Type); 11165 else 11166 exit; 11167 end if; 11168 11169 elsif 11170 Ekind (Act_F_Type) = E_Anonymous_Access_Type 11171 then 11172 exit; 11173 end if; 11174 11175 Anc_F_Type := Base_Type (Anc_F_Type); 11176 Act_F_Type := Base_Type (Act_F_Type); 11177 11178 -- If the formal is controlling, then the 11179 -- the type of the actual primitive's formal 11180 -- must be derived directly or indirectly 11181 -- from the type of the ancestor primitive's 11182 -- formal. 11183 11184 if Is_Controlling_Formal (Anc_Formal) then 11185 if not Is_Tagged_Ancestor 11186 (Anc_F_Type, Act_F_Type) 11187 then 11188 exit; 11189 end if; 11190 11191 -- Otherwise the types of the formals must 11192 -- be the same. 11193 11194 elsif Anc_F_Type /= Act_F_Type then 11195 exit; 11196 end if; 11197 11198 Next_Entity (Anc_Formal); 11199 Next_Entity (Act_Formal); 11200 end loop; 11201 11202 -- If we traversed through all of the formals 11203 -- then so far the subprograms correspond, so 11204 -- now check that any result types correspond. 11205 11206 if No (Anc_Formal) and then No (Act_Formal) then 11207 Subprograms_Correspond := True; 11208 11209 if Ekind (Act_Subp) = E_Function then 11210 Anc_F_Type := Etype (Anc_Subp); 11211 Act_F_Type := Etype (Act_Subp); 11212 11213 if Ekind (Anc_F_Type) 11214 = E_Anonymous_Access_Type 11215 then 11216 Anc_F_Type := 11217 Designated_Type (Anc_F_Type); 11218 11219 if Ekind (Act_F_Type) 11220 = E_Anonymous_Access_Type 11221 then 11222 Act_F_Type := 11223 Designated_Type (Act_F_Type); 11224 else 11225 Subprograms_Correspond := False; 11226 end if; 11227 11228 elsif 11229 Ekind (Act_F_Type) 11230 = E_Anonymous_Access_Type 11231 then 11232 Subprograms_Correspond := False; 11233 end if; 11234 11235 Anc_F_Type := Base_Type (Anc_F_Type); 11236 Act_F_Type := Base_Type (Act_F_Type); 11237 11238 -- Now either the result types must be 11239 -- the same or, if the result type is 11240 -- controlling, the result type of the 11241 -- actual primitive must descend from the 11242 -- result type of the ancestor primitive. 11243 11244 if Subprograms_Correspond 11245 and then Anc_F_Type /= Act_F_Type 11246 and then 11247 Has_Controlling_Result (Anc_Subp) 11248 and then 11249 not Is_Tagged_Ancestor 11250 (Anc_F_Type, Act_F_Type) 11251 then 11252 Subprograms_Correspond := False; 11253 end if; 11254 end if; 11255 11256 -- Found a matching subprogram belonging to 11257 -- formal ancestor type, so actual subprogram 11258 -- corresponds and this violates 3.9.3(9). 11259 11260 if Subprograms_Correspond then 11261 Error_Msg_NE 11262 ("abstract subprogram & overrides " & 11263 "nonabstract subprogram of ancestor", 11264 Actual, 11265 Act_Subp); 11266 end if; 11267 end if; 11268 end if; 11269 end if; 11270 11271 Next_Elmt (Act_Elmt); 11272 end loop; 11273 end if; 11274 11275 Next_Elmt (Gen_Elmt); 11276 end loop; 11277 end Check_Abstract_Primitives; 11278 end if; 11279 11280 -- Verify that limitedness matches. If parent is a limited 11281 -- interface then the generic formal is not unless declared 11282 -- explicitly so. If not declared limited, the actual cannot be 11283 -- limited (see AI05-0087). 11284 11285 -- Even though this AI is a binding interpretation, we enable the 11286 -- check only in Ada 2012 mode, because this improper construct 11287 -- shows up in user code and in existing B-tests. 11288 11289 if Is_Limited_Type (Act_T) 11290 and then not Is_Limited_Type (A_Gen_T) 11291 and then Ada_Version >= Ada_2012 11292 then 11293 if In_Instance then 11294 null; 11295 else 11296 Error_Msg_NE 11297 ("actual for non-limited & cannot be a limited type", Actual, 11298 Gen_T); 11299 Explain_Limited_Type (Act_T, Actual); 11300 Abandon_Instantiation (Actual); 11301 end if; 11302 end if; 11303 end Validate_Derived_Type_Instance; 11304 11305 ---------------------------------------- 11306 -- Validate_Discriminated_Formal_Type -- 11307 ---------------------------------------- 11308 11309 procedure Validate_Discriminated_Formal_Type is 11310 Formal_Discr : Entity_Id; 11311 Actual_Discr : Entity_Id; 11312 Formal_Subt : Entity_Id; 11313 11314 begin 11315 if Has_Discriminants (A_Gen_T) then 11316 if not Has_Discriminants (Act_T) then 11317 Error_Msg_NE 11318 ("actual for & must have discriminants", Actual, Gen_T); 11319 Abandon_Instantiation (Actual); 11320 11321 elsif Is_Constrained (Act_T) then 11322 Error_Msg_NE 11323 ("actual for & must be unconstrained", Actual, Gen_T); 11324 Abandon_Instantiation (Actual); 11325 11326 else 11327 Formal_Discr := First_Discriminant (A_Gen_T); 11328 Actual_Discr := First_Discriminant (Act_T); 11329 while Formal_Discr /= Empty loop 11330 if Actual_Discr = Empty then 11331 Error_Msg_NE 11332 ("discriminants on actual do not match formal", 11333 Actual, Gen_T); 11334 Abandon_Instantiation (Actual); 11335 end if; 11336 11337 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 11338 11339 -- Access discriminants match if designated types do 11340 11341 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 11342 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 11343 E_Anonymous_Access_Type 11344 and then 11345 Get_Instance_Of 11346 (Designated_Type (Base_Type (Formal_Subt))) = 11347 Designated_Type (Base_Type (Etype (Actual_Discr))) 11348 then 11349 null; 11350 11351 elsif Base_Type (Formal_Subt) /= 11352 Base_Type (Etype (Actual_Discr)) 11353 then 11354 Error_Msg_NE 11355 ("types of actual discriminants must match formal", 11356 Actual, Gen_T); 11357 Abandon_Instantiation (Actual); 11358 11359 elsif not Subtypes_Statically_Match 11360 (Formal_Subt, Etype (Actual_Discr)) 11361 and then Ada_Version >= Ada_95 11362 then 11363 Error_Msg_NE 11364 ("subtypes of actual discriminants must match formal", 11365 Actual, Gen_T); 11366 Abandon_Instantiation (Actual); 11367 end if; 11368 11369 Next_Discriminant (Formal_Discr); 11370 Next_Discriminant (Actual_Discr); 11371 end loop; 11372 11373 if Actual_Discr /= Empty then 11374 Error_Msg_NE 11375 ("discriminants on actual do not match formal", 11376 Actual, Gen_T); 11377 Abandon_Instantiation (Actual); 11378 end if; 11379 end if; 11380 end if; 11381 end Validate_Discriminated_Formal_Type; 11382 11383 --------------------------------------- 11384 -- Validate_Incomplete_Type_Instance -- 11385 --------------------------------------- 11386 11387 procedure Validate_Incomplete_Type_Instance is 11388 begin 11389 if not Is_Tagged_Type (Act_T) 11390 and then Is_Tagged_Type (A_Gen_T) 11391 then 11392 Error_Msg_NE 11393 ("actual for & must be a tagged type", Actual, Gen_T); 11394 end if; 11395 11396 Validate_Discriminated_Formal_Type; 11397 end Validate_Incomplete_Type_Instance; 11398 11399 -------------------------------------- 11400 -- Validate_Interface_Type_Instance -- 11401 -------------------------------------- 11402 11403 procedure Validate_Interface_Type_Instance is 11404 begin 11405 if not Is_Interface (Act_T) then 11406 Error_Msg_NE 11407 ("actual for formal interface type must be an interface", 11408 Actual, Gen_T); 11409 11410 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 11411 or else 11412 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 11413 or else 11414 Is_Protected_Interface (A_Gen_T) /= 11415 Is_Protected_Interface (Act_T) 11416 or else 11417 Is_Synchronized_Interface (A_Gen_T) /= 11418 Is_Synchronized_Interface (Act_T) 11419 then 11420 Error_Msg_NE 11421 ("actual for interface& does not match (RM 12.5.5(4))", 11422 Actual, Gen_T); 11423 end if; 11424 end Validate_Interface_Type_Instance; 11425 11426 ------------------------------------ 11427 -- Validate_Private_Type_Instance -- 11428 ------------------------------------ 11429 11430 procedure Validate_Private_Type_Instance is 11431 begin 11432 if Is_Limited_Type (Act_T) 11433 and then not Is_Limited_Type (A_Gen_T) 11434 then 11435 if In_Instance then 11436 null; 11437 else 11438 Error_Msg_NE 11439 ("actual for non-limited & cannot be a limited type", Actual, 11440 Gen_T); 11441 Explain_Limited_Type (Act_T, Actual); 11442 Abandon_Instantiation (Actual); 11443 end if; 11444 11445 elsif Known_To_Have_Preelab_Init (A_Gen_T) 11446 and then not Has_Preelaborable_Initialization (Act_T) 11447 then 11448 Error_Msg_NE 11449 ("actual for & must have preelaborable initialization", Actual, 11450 Gen_T); 11451 11452 elsif Is_Indefinite_Subtype (Act_T) 11453 and then not Is_Indefinite_Subtype (A_Gen_T) 11454 and then Ada_Version >= Ada_95 11455 then 11456 Error_Msg_NE 11457 ("actual for & must be a definite subtype", Actual, Gen_T); 11458 11459 elsif not Is_Tagged_Type (Act_T) 11460 and then Is_Tagged_Type (A_Gen_T) 11461 then 11462 Error_Msg_NE 11463 ("actual for & must be a tagged type", Actual, Gen_T); 11464 end if; 11465 11466 Validate_Discriminated_Formal_Type; 11467 Ancestor := Gen_T; 11468 end Validate_Private_Type_Instance; 11469 11470 -- Start of processing for Instantiate_Type 11471 11472 begin 11473 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 11474 Error_Msg_N ("duplicate instantiation of generic type", Actual); 11475 return New_List (Error); 11476 11477 elsif not Is_Entity_Name (Actual) 11478 or else not Is_Type (Entity (Actual)) 11479 then 11480 Error_Msg_NE 11481 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 11482 Abandon_Instantiation (Actual); 11483 11484 else 11485 Act_T := Entity (Actual); 11486 11487 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 11488 -- as a generic actual parameter if the corresponding formal type 11489 -- does not have a known_discriminant_part, or is a formal derived 11490 -- type that is an Unchecked_Union type. 11491 11492 if Is_Unchecked_Union (Base_Type (Act_T)) then 11493 if not Has_Discriminants (A_Gen_T) 11494 or else 11495 (Is_Derived_Type (A_Gen_T) 11496 and then 11497 Is_Unchecked_Union (A_Gen_T)) 11498 then 11499 null; 11500 else 11501 Error_Msg_N ("unchecked union cannot be the actual for a" & 11502 " discriminated formal type", Act_T); 11503 11504 end if; 11505 end if; 11506 11507 -- Deal with fixed/floating restrictions 11508 11509 if Is_Floating_Point_Type (Act_T) then 11510 Check_Restriction (No_Floating_Point, Actual); 11511 elsif Is_Fixed_Point_Type (Act_T) then 11512 Check_Restriction (No_Fixed_Point, Actual); 11513 end if; 11514 11515 -- Deal with error of using incomplete type as generic actual. 11516 -- This includes limited views of a type, even if the non-limited 11517 -- view may be available. 11518 11519 if Ekind (Act_T) = E_Incomplete_Type 11520 or else (Is_Class_Wide_Type (Act_T) 11521 and then 11522 Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 11523 then 11524 -- If the formal is an incomplete type, the actual can be 11525 -- incomplete as well. 11526 11527 if Ekind (A_Gen_T) = E_Incomplete_Type then 11528 null; 11529 11530 elsif Is_Class_Wide_Type (Act_T) 11531 or else No (Full_View (Act_T)) 11532 then 11533 Error_Msg_N ("premature use of incomplete type", Actual); 11534 Abandon_Instantiation (Actual); 11535 else 11536 Act_T := Full_View (Act_T); 11537 Set_Entity (Actual, Act_T); 11538 11539 if Has_Private_Component (Act_T) then 11540 Error_Msg_N 11541 ("premature use of type with private component", Actual); 11542 end if; 11543 end if; 11544 11545 -- Deal with error of premature use of private type as generic actual 11546 11547 elsif Is_Private_Type (Act_T) 11548 and then Is_Private_Type (Base_Type (Act_T)) 11549 and then not Is_Generic_Type (Act_T) 11550 and then not Is_Derived_Type (Act_T) 11551 and then No (Full_View (Root_Type (Act_T))) 11552 then 11553 -- If the formal is an incomplete type, the actual can be 11554 -- private or incomplete as well. 11555 11556 if Ekind (A_Gen_T) = E_Incomplete_Type then 11557 null; 11558 else 11559 Error_Msg_N ("premature use of private type", Actual); 11560 end if; 11561 11562 elsif Has_Private_Component (Act_T) then 11563 Error_Msg_N 11564 ("premature use of type with private component", Actual); 11565 end if; 11566 11567 Set_Instance_Of (A_Gen_T, Act_T); 11568 11569 -- If the type is generic, the class-wide type may also be used 11570 11571 if Is_Tagged_Type (A_Gen_T) 11572 and then Is_Tagged_Type (Act_T) 11573 and then not Is_Class_Wide_Type (A_Gen_T) 11574 then 11575 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 11576 Class_Wide_Type (Act_T)); 11577 end if; 11578 11579 if not Is_Abstract_Type (A_Gen_T) 11580 and then Is_Abstract_Type (Act_T) 11581 then 11582 Error_Msg_N 11583 ("actual of non-abstract formal cannot be abstract", Actual); 11584 end if; 11585 11586 -- A generic scalar type is a first subtype for which we generate 11587 -- an anonymous base type. Indicate that the instance of this base 11588 -- is the base type of the actual. 11589 11590 if Is_Scalar_Type (A_Gen_T) then 11591 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 11592 end if; 11593 end if; 11594 11595 if Error_Posted (Act_T) then 11596 null; 11597 else 11598 case Nkind (Def) is 11599 when N_Formal_Private_Type_Definition => 11600 Validate_Private_Type_Instance; 11601 11602 when N_Formal_Incomplete_Type_Definition => 11603 Validate_Incomplete_Type_Instance; 11604 11605 when N_Formal_Derived_Type_Definition => 11606 Validate_Derived_Type_Instance; 11607 11608 when N_Formal_Discrete_Type_Definition => 11609 if not Is_Discrete_Type (Act_T) then 11610 Error_Msg_NE 11611 ("expect discrete type in instantiation of&", 11612 Actual, Gen_T); 11613 Abandon_Instantiation (Actual); 11614 end if; 11615 11616 when N_Formal_Signed_Integer_Type_Definition => 11617 if not Is_Signed_Integer_Type (Act_T) then 11618 Error_Msg_NE 11619 ("expect signed integer type in instantiation of&", 11620 Actual, Gen_T); 11621 Abandon_Instantiation (Actual); 11622 end if; 11623 11624 when N_Formal_Modular_Type_Definition => 11625 if not Is_Modular_Integer_Type (Act_T) then 11626 Error_Msg_NE 11627 ("expect modular type in instantiation of &", 11628 Actual, Gen_T); 11629 Abandon_Instantiation (Actual); 11630 end if; 11631 11632 when N_Formal_Floating_Point_Definition => 11633 if not Is_Floating_Point_Type (Act_T) then 11634 Error_Msg_NE 11635 ("expect float type in instantiation of &", Actual, Gen_T); 11636 Abandon_Instantiation (Actual); 11637 end if; 11638 11639 when N_Formal_Ordinary_Fixed_Point_Definition => 11640 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 11641 Error_Msg_NE 11642 ("expect ordinary fixed point type in instantiation of &", 11643 Actual, Gen_T); 11644 Abandon_Instantiation (Actual); 11645 end if; 11646 11647 when N_Formal_Decimal_Fixed_Point_Definition => 11648 if not Is_Decimal_Fixed_Point_Type (Act_T) then 11649 Error_Msg_NE 11650 ("expect decimal type in instantiation of &", 11651 Actual, Gen_T); 11652 Abandon_Instantiation (Actual); 11653 end if; 11654 11655 when N_Array_Type_Definition => 11656 Validate_Array_Type_Instance; 11657 11658 when N_Access_To_Object_Definition => 11659 Validate_Access_Type_Instance; 11660 11661 when N_Access_Function_Definition | 11662 N_Access_Procedure_Definition => 11663 Validate_Access_Subprogram_Instance; 11664 11665 when N_Record_Definition => 11666 Validate_Interface_Type_Instance; 11667 11668 when N_Derived_Type_Definition => 11669 Validate_Derived_Interface_Type_Instance; 11670 11671 when others => 11672 raise Program_Error; 11673 11674 end case; 11675 end if; 11676 11677 Subt := New_Copy (Gen_T); 11678 11679 -- Use adjusted sloc of subtype name as the location for other nodes in 11680 -- the subtype declaration. 11681 11682 Loc := Sloc (Subt); 11683 11684 Decl_Node := 11685 Make_Subtype_Declaration (Loc, 11686 Defining_Identifier => Subt, 11687 Subtype_Indication => New_Reference_To (Act_T, Loc)); 11688 11689 if Is_Private_Type (Act_T) then 11690 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 11691 11692 elsif Is_Access_Type (Act_T) 11693 and then Is_Private_Type (Designated_Type (Act_T)) 11694 then 11695 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 11696 end if; 11697 11698 Decl_Nodes := New_List (Decl_Node); 11699 11700 -- Flag actual derived types so their elaboration produces the 11701 -- appropriate renamings for the primitive operations of the ancestor. 11702 -- Flag actual for formal private types as well, to determine whether 11703 -- operations in the private part may override inherited operations. 11704 -- If the formal has an interface list, the ancestor is not the 11705 -- parent, but the analyzed formal that includes the interface 11706 -- operations of all its progenitors. 11707 11708 -- Same treatment for formal private types, so we can check whether the 11709 -- type is tagged limited when validating derivations in the private 11710 -- part. (See AI05-096). 11711 11712 if Nkind (Def) = N_Formal_Derived_Type_Definition then 11713 if Present (Interface_List (Def)) then 11714 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 11715 else 11716 Set_Generic_Parent_Type (Decl_Node, Ancestor); 11717 end if; 11718 11719 elsif Nkind_In (Def, 11720 N_Formal_Private_Type_Definition, 11721 N_Formal_Incomplete_Type_Definition) 11722 then 11723 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 11724 end if; 11725 11726 -- If the actual is a synchronized type that implements an interface, 11727 -- the primitive operations are attached to the corresponding record, 11728 -- and we have to treat it as an additional generic actual, so that its 11729 -- primitive operations become visible in the instance. The task or 11730 -- protected type itself does not carry primitive operations. 11731 11732 if Is_Concurrent_Type (Act_T) 11733 and then Is_Tagged_Type (Act_T) 11734 and then Present (Corresponding_Record_Type (Act_T)) 11735 and then Present (Ancestor) 11736 and then Is_Interface (Ancestor) 11737 then 11738 declare 11739 Corr_Rec : constant Entity_Id := 11740 Corresponding_Record_Type (Act_T); 11741 New_Corr : Entity_Id; 11742 Corr_Decl : Node_Id; 11743 11744 begin 11745 New_Corr := Make_Temporary (Loc, 'S'); 11746 Corr_Decl := 11747 Make_Subtype_Declaration (Loc, 11748 Defining_Identifier => New_Corr, 11749 Subtype_Indication => 11750 New_Reference_To (Corr_Rec, Loc)); 11751 Append_To (Decl_Nodes, Corr_Decl); 11752 11753 if Ekind (Act_T) = E_Task_Type then 11754 Set_Ekind (Subt, E_Task_Subtype); 11755 else 11756 Set_Ekind (Subt, E_Protected_Subtype); 11757 end if; 11758 11759 Set_Corresponding_Record_Type (Subt, Corr_Rec); 11760 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 11761 Set_Generic_Parent_Type (Decl_Node, Empty); 11762 end; 11763 end if; 11764 11765 return Decl_Nodes; 11766 end Instantiate_Type; 11767 11768 --------------------- 11769 -- Is_In_Main_Unit -- 11770 --------------------- 11771 11772 function Is_In_Main_Unit (N : Node_Id) return Boolean is 11773 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 11774 Current_Unit : Node_Id; 11775 11776 begin 11777 if Unum = Main_Unit then 11778 return True; 11779 11780 -- If the current unit is a subunit then it is either the main unit or 11781 -- is being compiled as part of the main unit. 11782 11783 elsif Nkind (N) = N_Compilation_Unit then 11784 return Nkind (Unit (N)) = N_Subunit; 11785 end if; 11786 11787 Current_Unit := Parent (N); 11788 while Present (Current_Unit) 11789 and then Nkind (Current_Unit) /= N_Compilation_Unit 11790 loop 11791 Current_Unit := Parent (Current_Unit); 11792 end loop; 11793 11794 -- The instantiation node is in the main unit, or else the current node 11795 -- (perhaps as the result of nested instantiations) is in the main unit, 11796 -- or in the declaration of the main unit, which in this last case must 11797 -- be a body. 11798 11799 return Unum = Main_Unit 11800 or else Current_Unit = Cunit (Main_Unit) 11801 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 11802 or else (Present (Library_Unit (Current_Unit)) 11803 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 11804 end Is_In_Main_Unit; 11805 11806 ---------------------------- 11807 -- Load_Parent_Of_Generic -- 11808 ---------------------------- 11809 11810 procedure Load_Parent_Of_Generic 11811 (N : Node_Id; 11812 Spec : Node_Id; 11813 Body_Optional : Boolean := False) 11814 is 11815 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 11816 Save_Style_Check : constant Boolean := Style_Check; 11817 True_Parent : Node_Id; 11818 Inst_Node : Node_Id; 11819 OK : Boolean; 11820 Previous_Instances : constant Elist_Id := New_Elmt_List; 11821 11822 procedure Collect_Previous_Instances (Decls : List_Id); 11823 -- Collect all instantiations in the given list of declarations, that 11824 -- precede the generic that we need to load. If the bodies of these 11825 -- instantiations are available, we must analyze them, to ensure that 11826 -- the public symbols generated are the same when the unit is compiled 11827 -- to generate code, and when it is compiled in the context of a unit 11828 -- that needs a particular nested instance. This process is applied to 11829 -- both package and subprogram instances. 11830 11831 -------------------------------- 11832 -- Collect_Previous_Instances -- 11833 -------------------------------- 11834 11835 procedure Collect_Previous_Instances (Decls : List_Id) is 11836 Decl : Node_Id; 11837 11838 begin 11839 Decl := First (Decls); 11840 while Present (Decl) loop 11841 if Sloc (Decl) >= Sloc (Inst_Node) then 11842 return; 11843 11844 -- If Decl is an instantiation, then record it as requiring 11845 -- instantiation of the corresponding body, except if it is an 11846 -- abbreviated instantiation generated internally for conformance 11847 -- checking purposes only for the case of a formal package 11848 -- declared without a box (see Instantiate_Formal_Package). Such 11849 -- an instantiation does not generate any code (the actual code 11850 -- comes from actual) and thus does not need to be analyzed here. 11851 -- If the instantiation appears with a generic package body it is 11852 -- not analyzed here either. 11853 11854 elsif Nkind (Decl) = N_Package_Instantiation 11855 and then not Is_Internal (Defining_Entity (Decl)) 11856 then 11857 Append_Elmt (Decl, Previous_Instances); 11858 11859 -- For a subprogram instantiation, omit instantiations intrinsic 11860 -- operations (Unchecked_Conversions, etc.) that have no bodies. 11861 11862 elsif Nkind_In (Decl, N_Function_Instantiation, 11863 N_Procedure_Instantiation) 11864 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 11865 then 11866 Append_Elmt (Decl, Previous_Instances); 11867 11868 elsif Nkind (Decl) = N_Package_Declaration then 11869 Collect_Previous_Instances 11870 (Visible_Declarations (Specification (Decl))); 11871 Collect_Previous_Instances 11872 (Private_Declarations (Specification (Decl))); 11873 11874 -- Previous non-generic bodies may contain instances as well 11875 11876 elsif Nkind (Decl) = N_Package_Body 11877 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 11878 then 11879 Collect_Previous_Instances (Declarations (Decl)); 11880 11881 elsif Nkind (Decl) = N_Subprogram_Body 11882 and then not Acts_As_Spec (Decl) 11883 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 11884 then 11885 Collect_Previous_Instances (Declarations (Decl)); 11886 end if; 11887 11888 Next (Decl); 11889 end loop; 11890 end Collect_Previous_Instances; 11891 11892 -- Start of processing for Load_Parent_Of_Generic 11893 11894 begin 11895 if not In_Same_Source_Unit (N, Spec) 11896 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 11897 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 11898 and then not Is_In_Main_Unit (Spec)) 11899 then 11900 -- Find body of parent of spec, and analyze it. A special case arises 11901 -- when the parent is an instantiation, that is to say when we are 11902 -- currently instantiating a nested generic. In that case, there is 11903 -- no separate file for the body of the enclosing instance. Instead, 11904 -- the enclosing body must be instantiated as if it were a pending 11905 -- instantiation, in order to produce the body for the nested generic 11906 -- we require now. Note that in that case the generic may be defined 11907 -- in a package body, the instance defined in the same package body, 11908 -- and the original enclosing body may not be in the main unit. 11909 11910 Inst_Node := Empty; 11911 11912 True_Parent := Parent (Spec); 11913 while Present (True_Parent) 11914 and then Nkind (True_Parent) /= N_Compilation_Unit 11915 loop 11916 if Nkind (True_Parent) = N_Package_Declaration 11917 and then 11918 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 11919 then 11920 -- Parent is a compilation unit that is an instantiation. 11921 -- Instantiation node has been replaced with package decl. 11922 11923 Inst_Node := Original_Node (True_Parent); 11924 exit; 11925 11926 elsif Nkind (True_Parent) = N_Package_Declaration 11927 and then Present (Generic_Parent (Specification (True_Parent))) 11928 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 11929 then 11930 -- Parent is an instantiation within another specification. 11931 -- Declaration for instance has been inserted before original 11932 -- instantiation node. A direct link would be preferable? 11933 11934 Inst_Node := Next (True_Parent); 11935 while Present (Inst_Node) 11936 and then Nkind (Inst_Node) /= N_Package_Instantiation 11937 loop 11938 Next (Inst_Node); 11939 end loop; 11940 11941 -- If the instance appears within a generic, and the generic 11942 -- unit is defined within a formal package of the enclosing 11943 -- generic, there is no generic body available, and none 11944 -- needed. A more precise test should be used ??? 11945 11946 if No (Inst_Node) then 11947 return; 11948 end if; 11949 11950 exit; 11951 11952 else 11953 True_Parent := Parent (True_Parent); 11954 end if; 11955 end loop; 11956 11957 -- Case where we are currently instantiating a nested generic 11958 11959 if Present (Inst_Node) then 11960 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 11961 11962 -- Instantiation node and declaration of instantiated package 11963 -- were exchanged when only the declaration was needed. 11964 -- Restore instantiation node before proceeding with body. 11965 11966 Set_Unit (Parent (True_Parent), Inst_Node); 11967 end if; 11968 11969 -- Now complete instantiation of enclosing body, if it appears in 11970 -- some other unit. If it appears in the current unit, the body 11971 -- will have been instantiated already. 11972 11973 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 11974 11975 -- We need to determine the expander mode to instantiate the 11976 -- enclosing body. Because the generic body we need may use 11977 -- global entities declared in the enclosing package (including 11978 -- aggregates) it is in general necessary to compile this body 11979 -- with expansion enabled, except if we are within a generic 11980 -- package, in which case the usual generic rule applies. 11981 11982 declare 11983 Exp_Status : Boolean := True; 11984 Scop : Entity_Id; 11985 11986 begin 11987 -- Loop through scopes looking for generic package 11988 11989 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 11990 while Present (Scop) 11991 and then Scop /= Standard_Standard 11992 loop 11993 if Ekind (Scop) = E_Generic_Package then 11994 Exp_Status := False; 11995 exit; 11996 end if; 11997 11998 Scop := Scope (Scop); 11999 end loop; 12000 12001 -- Collect previous instantiations in the unit that contains 12002 -- the desired generic. 12003 12004 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 12005 and then not Body_Optional 12006 then 12007 declare 12008 Decl : Elmt_Id; 12009 Info : Pending_Body_Info; 12010 Par : Node_Id; 12011 12012 begin 12013 Par := Parent (Inst_Node); 12014 while Present (Par) loop 12015 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 12016 Par := Parent (Par); 12017 end loop; 12018 12019 pragma Assert (Present (Par)); 12020 12021 if Nkind (Par) = N_Package_Body then 12022 Collect_Previous_Instances (Declarations (Par)); 12023 12024 elsif Nkind (Par) = N_Package_Declaration then 12025 Collect_Previous_Instances 12026 (Visible_Declarations (Specification (Par))); 12027 Collect_Previous_Instances 12028 (Private_Declarations (Specification (Par))); 12029 12030 else 12031 -- Enclosing unit is a subprogram body. In this 12032 -- case all instance bodies are processed in order 12033 -- and there is no need to collect them separately. 12034 12035 null; 12036 end if; 12037 12038 Decl := First_Elmt (Previous_Instances); 12039 while Present (Decl) loop 12040 Info := 12041 (Inst_Node => Node (Decl), 12042 Act_Decl => 12043 Instance_Spec (Node (Decl)), 12044 Expander_Status => Exp_Status, 12045 Current_Sem_Unit => 12046 Get_Code_Unit (Sloc (Node (Decl))), 12047 Scope_Suppress => Scope_Suppress, 12048 Local_Suppress_Stack_Top => 12049 Local_Suppress_Stack_Top, 12050 Version => Ada_Version); 12051 12052 -- Package instance 12053 12054 if 12055 Nkind (Node (Decl)) = N_Package_Instantiation 12056 then 12057 Instantiate_Package_Body 12058 (Info, Body_Optional => True); 12059 12060 -- Subprogram instance 12061 12062 else 12063 -- The instance_spec is the wrapper package, 12064 -- and the subprogram declaration is the last 12065 -- declaration in the wrapper. 12066 12067 Info.Act_Decl := 12068 Last 12069 (Visible_Declarations 12070 (Specification (Info.Act_Decl))); 12071 12072 Instantiate_Subprogram_Body 12073 (Info, Body_Optional => True); 12074 end if; 12075 12076 Next_Elmt (Decl); 12077 end loop; 12078 end; 12079 end if; 12080 12081 Instantiate_Package_Body 12082 (Body_Info => 12083 ((Inst_Node => Inst_Node, 12084 Act_Decl => True_Parent, 12085 Expander_Status => Exp_Status, 12086 Current_Sem_Unit => 12087 Get_Code_Unit (Sloc (Inst_Node)), 12088 Scope_Suppress => Scope_Suppress, 12089 Local_Suppress_Stack_Top => 12090 Local_Suppress_Stack_Top, 12091 Version => Ada_Version)), 12092 Body_Optional => Body_Optional); 12093 end; 12094 end if; 12095 12096 -- Case where we are not instantiating a nested generic 12097 12098 else 12099 Opt.Style_Check := False; 12100 Expander_Mode_Save_And_Set (True); 12101 Load_Needed_Body (Comp_Unit, OK); 12102 Opt.Style_Check := Save_Style_Check; 12103 Expander_Mode_Restore; 12104 12105 if not OK 12106 and then Unit_Requires_Body (Defining_Entity (Spec)) 12107 and then not Body_Optional 12108 then 12109 declare 12110 Bname : constant Unit_Name_Type := 12111 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 12112 12113 begin 12114 -- In CodePeer mode, the missing body may make the analysis 12115 -- incomplete, but we do not treat it as fatal. 12116 12117 if CodePeer_Mode then 12118 return; 12119 12120 else 12121 Error_Msg_Unit_1 := Bname; 12122 Error_Msg_N ("this instantiation requires$!", N); 12123 Error_Msg_File_1 := 12124 Get_File_Name (Bname, Subunit => False); 12125 Error_Msg_N ("\but file{ was not found!", N); 12126 raise Unrecoverable_Error; 12127 end if; 12128 end; 12129 end if; 12130 end if; 12131 end if; 12132 12133 -- If loading parent of the generic caused an instantiation circularity, 12134 -- we abandon compilation at this point, because otherwise in some cases 12135 -- we get into trouble with infinite recursions after this point. 12136 12137 if Circularity_Detected then 12138 raise Unrecoverable_Error; 12139 end if; 12140 end Load_Parent_Of_Generic; 12141 12142 --------------------------------- 12143 -- Map_Formal_Package_Entities -- 12144 --------------------------------- 12145 12146 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 12147 E1 : Entity_Id; 12148 E2 : Entity_Id; 12149 12150 begin 12151 Set_Instance_Of (Form, Act); 12152 12153 -- Traverse formal and actual package to map the corresponding entities. 12154 -- We skip over internal entities that may be generated during semantic 12155 -- analysis, and find the matching entities by name, given that they 12156 -- must appear in the same order. 12157 12158 E1 := First_Entity (Form); 12159 E2 := First_Entity (Act); 12160 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 12161 -- Could this test be a single condition??? Seems like it could, and 12162 -- isn't FPE (Form) a constant anyway??? 12163 12164 if not Is_Internal (E1) 12165 and then Present (Parent (E1)) 12166 and then not Is_Class_Wide_Type (E1) 12167 and then not Is_Internal_Name (Chars (E1)) 12168 then 12169 while Present (E2) and then Chars (E2) /= Chars (E1) loop 12170 Next_Entity (E2); 12171 end loop; 12172 12173 if No (E2) then 12174 exit; 12175 else 12176 Set_Instance_Of (E1, E2); 12177 12178 if Is_Type (E1) and then Is_Tagged_Type (E2) then 12179 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 12180 end if; 12181 12182 if Is_Constrained (E1) then 12183 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 12184 end if; 12185 12186 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 12187 Map_Formal_Package_Entities (E1, E2); 12188 end if; 12189 end if; 12190 end if; 12191 12192 Next_Entity (E1); 12193 end loop; 12194 end Map_Formal_Package_Entities; 12195 12196 ----------------------- 12197 -- Move_Freeze_Nodes -- 12198 ----------------------- 12199 12200 procedure Move_Freeze_Nodes 12201 (Out_Of : Entity_Id; 12202 After : Node_Id; 12203 L : List_Id) 12204 is 12205 Decl : Node_Id; 12206 Next_Decl : Node_Id; 12207 Next_Node : Node_Id := After; 12208 Spec : Node_Id; 12209 12210 function Is_Outer_Type (T : Entity_Id) return Boolean; 12211 -- Check whether entity is declared in a scope external to that of the 12212 -- generic unit. 12213 12214 ------------------- 12215 -- Is_Outer_Type -- 12216 ------------------- 12217 12218 function Is_Outer_Type (T : Entity_Id) return Boolean is 12219 Scop : Entity_Id := Scope (T); 12220 12221 begin 12222 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 12223 return True; 12224 12225 else 12226 while Scop /= Standard_Standard loop 12227 if Scop = Out_Of then 12228 return False; 12229 else 12230 Scop := Scope (Scop); 12231 end if; 12232 end loop; 12233 12234 return True; 12235 end if; 12236 end Is_Outer_Type; 12237 12238 -- Start of processing for Move_Freeze_Nodes 12239 12240 begin 12241 if No (L) then 12242 return; 12243 end if; 12244 12245 -- First remove the freeze nodes that may appear before all other 12246 -- declarations. 12247 12248 Decl := First (L); 12249 while Present (Decl) 12250 and then Nkind (Decl) = N_Freeze_Entity 12251 and then Is_Outer_Type (Entity (Decl)) 12252 loop 12253 Decl := Remove_Head (L); 12254 Insert_After (Next_Node, Decl); 12255 Set_Analyzed (Decl, False); 12256 Next_Node := Decl; 12257 Decl := First (L); 12258 end loop; 12259 12260 -- Next scan the list of declarations and remove each freeze node that 12261 -- appears ahead of the current node. 12262 12263 while Present (Decl) loop 12264 while Present (Next (Decl)) 12265 and then Nkind (Next (Decl)) = N_Freeze_Entity 12266 and then Is_Outer_Type (Entity (Next (Decl))) 12267 loop 12268 Next_Decl := Remove_Next (Decl); 12269 Insert_After (Next_Node, Next_Decl); 12270 Set_Analyzed (Next_Decl, False); 12271 Next_Node := Next_Decl; 12272 end loop; 12273 12274 -- If the declaration is a nested package or concurrent type, then 12275 -- recurse. Nested generic packages will have been processed from the 12276 -- inside out. 12277 12278 case Nkind (Decl) is 12279 when N_Package_Declaration => 12280 Spec := Specification (Decl); 12281 12282 when N_Task_Type_Declaration => 12283 Spec := Task_Definition (Decl); 12284 12285 when N_Protected_Type_Declaration => 12286 Spec := Protected_Definition (Decl); 12287 12288 when others => 12289 Spec := Empty; 12290 end case; 12291 12292 if Present (Spec) then 12293 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 12294 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 12295 end if; 12296 12297 Next (Decl); 12298 end loop; 12299 end Move_Freeze_Nodes; 12300 12301 ---------------- 12302 -- Next_Assoc -- 12303 ---------------- 12304 12305 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 12306 begin 12307 return Generic_Renamings.Table (E).Next_In_HTable; 12308 end Next_Assoc; 12309 12310 ------------------------ 12311 -- Preanalyze_Actuals -- 12312 ------------------------ 12313 12314 procedure Preanalyze_Actuals (N : Node_Id) is 12315 Assoc : Node_Id; 12316 Act : Node_Id; 12317 Errs : constant Int := Serious_Errors_Detected; 12318 12319 Cur : Entity_Id := Empty; 12320 -- Current homograph of the instance name 12321 12322 Vis : Boolean; 12323 -- Saved visibility status of the current homograph 12324 12325 begin 12326 Assoc := First (Generic_Associations (N)); 12327 12328 -- If the instance is a child unit, its name may hide an outer homonym, 12329 -- so make it invisible to perform name resolution on the actuals. 12330 12331 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 12332 and then Present 12333 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 12334 then 12335 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 12336 12337 if Is_Compilation_Unit (Cur) then 12338 Vis := Is_Immediately_Visible (Cur); 12339 Set_Is_Immediately_Visible (Cur, False); 12340 else 12341 Cur := Empty; 12342 end if; 12343 end if; 12344 12345 while Present (Assoc) loop 12346 if Nkind (Assoc) /= N_Others_Choice then 12347 Act := Explicit_Generic_Actual_Parameter (Assoc); 12348 12349 -- Within a nested instantiation, a defaulted actual is an empty 12350 -- association, so nothing to analyze. If the subprogram actual 12351 -- is an attribute, analyze prefix only, because actual is not a 12352 -- complete attribute reference. 12353 12354 -- If actual is an allocator, analyze expression only. The full 12355 -- analysis can generate code, and if instance is a compilation 12356 -- unit we have to wait until the package instance is installed 12357 -- to have a proper place to insert this code. 12358 12359 -- String literals may be operators, but at this point we do not 12360 -- know whether the actual is a formal subprogram or a string. 12361 12362 if No (Act) then 12363 null; 12364 12365 elsif Nkind (Act) = N_Attribute_Reference then 12366 Analyze (Prefix (Act)); 12367 12368 elsif Nkind (Act) = N_Explicit_Dereference then 12369 Analyze (Prefix (Act)); 12370 12371 elsif Nkind (Act) = N_Allocator then 12372 declare 12373 Expr : constant Node_Id := Expression (Act); 12374 12375 begin 12376 if Nkind (Expr) = N_Subtype_Indication then 12377 Analyze (Subtype_Mark (Expr)); 12378 12379 -- Analyze separately each discriminant constraint, when 12380 -- given with a named association. 12381 12382 declare 12383 Constr : Node_Id; 12384 12385 begin 12386 Constr := First (Constraints (Constraint (Expr))); 12387 while Present (Constr) loop 12388 if Nkind (Constr) = N_Discriminant_Association then 12389 Analyze (Expression (Constr)); 12390 else 12391 Analyze (Constr); 12392 end if; 12393 12394 Next (Constr); 12395 end loop; 12396 end; 12397 12398 else 12399 Analyze (Expr); 12400 end if; 12401 end; 12402 12403 elsif Nkind (Act) /= N_Operator_Symbol then 12404 Analyze (Act); 12405 end if; 12406 12407 if Errs /= Serious_Errors_Detected then 12408 12409 -- Do a minimal analysis of the generic, to prevent spurious 12410 -- warnings complaining about the generic being unreferenced, 12411 -- before abandoning the instantiation. 12412 12413 Analyze (Name (N)); 12414 12415 if Is_Entity_Name (Name (N)) 12416 and then Etype (Name (N)) /= Any_Type 12417 then 12418 Generate_Reference (Entity (Name (N)), Name (N)); 12419 Set_Is_Instantiated (Entity (Name (N))); 12420 end if; 12421 12422 if Present (Cur) then 12423 12424 -- For the case of a child instance hiding an outer homonym, 12425 -- provide additional warning which might explain the error. 12426 12427 Set_Is_Immediately_Visible (Cur, Vis); 12428 Error_Msg_NE ("& hides outer unit with the same name??", 12429 N, Defining_Unit_Name (N)); 12430 end if; 12431 12432 Abandon_Instantiation (Act); 12433 end if; 12434 end if; 12435 12436 Next (Assoc); 12437 end loop; 12438 12439 if Present (Cur) then 12440 Set_Is_Immediately_Visible (Cur, Vis); 12441 end if; 12442 end Preanalyze_Actuals; 12443 12444 ------------------- 12445 -- Remove_Parent -- 12446 ------------------- 12447 12448 procedure Remove_Parent (In_Body : Boolean := False) is 12449 S : Entity_Id := Current_Scope; 12450 -- S is the scope containing the instantiation just completed. The scope 12451 -- stack contains the parent instances of the instantiation, followed by 12452 -- the original S. 12453 12454 Cur_P : Entity_Id; 12455 E : Entity_Id; 12456 P : Entity_Id; 12457 Hidden : Elmt_Id; 12458 12459 begin 12460 -- After child instantiation is complete, remove from scope stack the 12461 -- extra copy of the current scope, and then remove parent instances. 12462 12463 if not In_Body then 12464 Pop_Scope; 12465 12466 while Current_Scope /= S loop 12467 P := Current_Scope; 12468 End_Package_Scope (Current_Scope); 12469 12470 if In_Open_Scopes (P) then 12471 E := First_Entity (P); 12472 while Present (E) loop 12473 Set_Is_Immediately_Visible (E, True); 12474 Next_Entity (E); 12475 end loop; 12476 12477 -- If instantiation is declared in a block, it is the enclosing 12478 -- scope that might be a parent instance. Note that only one 12479 -- block can be involved, because the parent instances have 12480 -- been installed within it. 12481 12482 if Ekind (P) = E_Block then 12483 Cur_P := Scope (P); 12484 else 12485 Cur_P := P; 12486 end if; 12487 12488 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 12489 -- We are within an instance of some sibling. Retain 12490 -- visibility of parent, for proper subsequent cleanup, and 12491 -- reinstall private declarations as well. 12492 12493 Set_In_Private_Part (P); 12494 Install_Private_Declarations (P); 12495 end if; 12496 12497 -- If the ultimate parent is a top-level unit recorded in 12498 -- Instance_Parent_Unit, then reset its visibility to what it was 12499 -- before instantiation. (It's not clear what the purpose is of 12500 -- testing whether Scope (P) is In_Open_Scopes, but that test was 12501 -- present before the ultimate parent test was added.???) 12502 12503 elsif not In_Open_Scopes (Scope (P)) 12504 or else (P = Instance_Parent_Unit 12505 and then not Parent_Unit_Visible) 12506 then 12507 Set_Is_Immediately_Visible (P, False); 12508 12509 -- If the current scope is itself an instantiation of a generic 12510 -- nested within P, and we are in the private part of body of this 12511 -- instantiation, restore the full views of P, that were removed 12512 -- in End_Package_Scope above. This obscure case can occur when a 12513 -- subunit of a generic contains an instance of a child unit of 12514 -- its generic parent unit. 12515 12516 elsif S = Current_Scope and then Is_Generic_Instance (S) then 12517 declare 12518 Par : constant Entity_Id := 12519 Generic_Parent 12520 (Specification (Unit_Declaration_Node (S))); 12521 begin 12522 if Present (Par) 12523 and then P = Scope (Par) 12524 and then (In_Package_Body (S) or else In_Private_Part (S)) 12525 then 12526 Set_In_Private_Part (P); 12527 Install_Private_Declarations (P); 12528 end if; 12529 end; 12530 end if; 12531 end loop; 12532 12533 -- Reset visibility of entities in the enclosing scope 12534 12535 Set_Is_Hidden_Open_Scope (Current_Scope, False); 12536 12537 Hidden := First_Elmt (Hidden_Entities); 12538 while Present (Hidden) loop 12539 Set_Is_Immediately_Visible (Node (Hidden), True); 12540 Next_Elmt (Hidden); 12541 end loop; 12542 12543 else 12544 -- Each body is analyzed separately, and there is no context that 12545 -- needs preserving from one body instance to the next, so remove all 12546 -- parent scopes that have been installed. 12547 12548 while Present (S) loop 12549 End_Package_Scope (S); 12550 Set_Is_Immediately_Visible (S, False); 12551 S := Current_Scope; 12552 exit when S = Standard_Standard; 12553 end loop; 12554 end if; 12555 end Remove_Parent; 12556 12557 ----------------- 12558 -- Restore_Env -- 12559 ----------------- 12560 12561 procedure Restore_Env is 12562 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 12563 12564 begin 12565 if No (Current_Instantiated_Parent.Act_Id) then 12566 -- Restore environment after subprogram inlining 12567 12568 Restore_Private_Views (Empty); 12569 end if; 12570 12571 Current_Instantiated_Parent := Saved.Instantiated_Parent; 12572 Exchanged_Views := Saved.Exchanged_Views; 12573 Hidden_Entities := Saved.Hidden_Entities; 12574 Current_Sem_Unit := Saved.Current_Sem_Unit; 12575 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 12576 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 12577 12578 Restore_Opt_Config_Switches (Saved.Switches); 12579 12580 Instance_Envs.Decrement_Last; 12581 end Restore_Env; 12582 12583 --------------------------- 12584 -- Restore_Private_Views -- 12585 --------------------------- 12586 12587 procedure Restore_Private_Views 12588 (Pack_Id : Entity_Id; 12589 Is_Package : Boolean := True) 12590 is 12591 M : Elmt_Id; 12592 E : Entity_Id; 12593 Typ : Entity_Id; 12594 Dep_Elmt : Elmt_Id; 12595 Dep_Typ : Node_Id; 12596 12597 procedure Restore_Nested_Formal (Formal : Entity_Id); 12598 -- Hide the generic formals of formal packages declared with box which 12599 -- were reachable in the current instantiation. 12600 12601 --------------------------- 12602 -- Restore_Nested_Formal -- 12603 --------------------------- 12604 12605 procedure Restore_Nested_Formal (Formal : Entity_Id) is 12606 Ent : Entity_Id; 12607 12608 begin 12609 if Present (Renamed_Object (Formal)) 12610 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 12611 then 12612 return; 12613 12614 elsif Present (Associated_Formal_Package (Formal)) then 12615 Ent := First_Entity (Formal); 12616 while Present (Ent) loop 12617 exit when Ekind (Ent) = E_Package 12618 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 12619 12620 Set_Is_Hidden (Ent); 12621 Set_Is_Potentially_Use_Visible (Ent, False); 12622 12623 -- If package, then recurse 12624 12625 if Ekind (Ent) = E_Package then 12626 Restore_Nested_Formal (Ent); 12627 end if; 12628 12629 Next_Entity (Ent); 12630 end loop; 12631 end if; 12632 end Restore_Nested_Formal; 12633 12634 -- Start of processing for Restore_Private_Views 12635 12636 begin 12637 M := First_Elmt (Exchanged_Views); 12638 while Present (M) loop 12639 Typ := Node (M); 12640 12641 -- Subtypes of types whose views have been exchanged, and that are 12642 -- defined within the instance, were not on the Private_Dependents 12643 -- list on entry to the instance, so they have to be exchanged 12644 -- explicitly now, in order to remain consistent with the view of the 12645 -- parent type. 12646 12647 if Ekind_In (Typ, E_Private_Type, 12648 E_Limited_Private_Type, 12649 E_Record_Type_With_Private) 12650 then 12651 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 12652 while Present (Dep_Elmt) loop 12653 Dep_Typ := Node (Dep_Elmt); 12654 12655 if Scope (Dep_Typ) = Pack_Id 12656 and then Present (Full_View (Dep_Typ)) 12657 then 12658 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 12659 Exchange_Declarations (Dep_Typ); 12660 end if; 12661 12662 Next_Elmt (Dep_Elmt); 12663 end loop; 12664 end if; 12665 12666 Exchange_Declarations (Node (M)); 12667 Next_Elmt (M); 12668 end loop; 12669 12670 if No (Pack_Id) then 12671 return; 12672 end if; 12673 12674 -- Make the generic formal parameters private, and make the formal types 12675 -- into subtypes of the actuals again. 12676 12677 E := First_Entity (Pack_Id); 12678 while Present (E) loop 12679 Set_Is_Hidden (E, True); 12680 12681 if Is_Type (E) 12682 and then Nkind (Parent (E)) = N_Subtype_Declaration 12683 then 12684 -- If the actual for E is itself a generic actual type from 12685 -- an enclosing instance, E is still a generic actual type 12686 -- outside of the current instance. This matter when resolving 12687 -- an overloaded call that may be ambiguous in the enclosing 12688 -- instance, when two of its actuals coincide. 12689 12690 if Is_Entity_Name (Subtype_Indication (Parent (E))) 12691 and then Is_Generic_Actual_Type 12692 (Entity (Subtype_Indication (Parent (E)))) 12693 then 12694 null; 12695 else 12696 Set_Is_Generic_Actual_Type (E, False); 12697 end if; 12698 12699 -- An unusual case of aliasing: the actual may also be directly 12700 -- visible in the generic, and be private there, while it is fully 12701 -- visible in the context of the instance. The internal subtype 12702 -- is private in the instance but has full visibility like its 12703 -- parent in the enclosing scope. This enforces the invariant that 12704 -- the privacy status of all private dependents of a type coincide 12705 -- with that of the parent type. This can only happen when a 12706 -- generic child unit is instantiated within a sibling. 12707 12708 if Is_Private_Type (E) 12709 and then not Is_Private_Type (Etype (E)) 12710 then 12711 Exchange_Declarations (E); 12712 end if; 12713 12714 elsif Ekind (E) = E_Package then 12715 12716 -- The end of the renaming list is the renaming of the generic 12717 -- package itself. If the instance is a subprogram, all entities 12718 -- in the corresponding package are renamings. If this entity is 12719 -- a formal package, make its own formals private as well. The 12720 -- actual in this case is itself the renaming of an instantiation. 12721 -- If the entity is not a package renaming, it is the entity 12722 -- created to validate formal package actuals: ignore it. 12723 12724 -- If the actual is itself a formal package for the enclosing 12725 -- generic, or the actual for such a formal package, it remains 12726 -- visible on exit from the instance, and therefore nothing needs 12727 -- to be done either, except to keep it accessible. 12728 12729 if Is_Package and then Renamed_Object (E) = Pack_Id then 12730 exit; 12731 12732 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 12733 null; 12734 12735 elsif 12736 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 12737 then 12738 Set_Is_Hidden (E, False); 12739 12740 else 12741 declare 12742 Act_P : constant Entity_Id := Renamed_Object (E); 12743 Id : Entity_Id; 12744 12745 begin 12746 Id := First_Entity (Act_P); 12747 while Present (Id) 12748 and then Id /= First_Private_Entity (Act_P) 12749 loop 12750 exit when Ekind (Id) = E_Package 12751 and then Renamed_Object (Id) = Act_P; 12752 12753 Set_Is_Hidden (Id, True); 12754 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 12755 12756 if Ekind (Id) = E_Package then 12757 Restore_Nested_Formal (Id); 12758 end if; 12759 12760 Next_Entity (Id); 12761 end loop; 12762 end; 12763 end if; 12764 end if; 12765 12766 Next_Entity (E); 12767 end loop; 12768 end Restore_Private_Views; 12769 12770 -------------- 12771 -- Save_Env -- 12772 -------------- 12773 12774 procedure Save_Env 12775 (Gen_Unit : Entity_Id; 12776 Act_Unit : Entity_Id) 12777 is 12778 begin 12779 Init_Env; 12780 Set_Instance_Env (Gen_Unit, Act_Unit); 12781 end Save_Env; 12782 12783 ---------------------------- 12784 -- Save_Global_References -- 12785 ---------------------------- 12786 12787 procedure Save_Global_References (N : Node_Id) is 12788 Gen_Scope : Entity_Id; 12789 E : Entity_Id; 12790 N2 : Node_Id; 12791 12792 function Is_Global (E : Entity_Id) return Boolean; 12793 -- Check whether entity is defined outside of generic unit. Examine the 12794 -- scope of an entity, and the scope of the scope, etc, until we find 12795 -- either Standard, in which case the entity is global, or the generic 12796 -- unit itself, which indicates that the entity is local. If the entity 12797 -- is the generic unit itself, as in the case of a recursive call, or 12798 -- the enclosing generic unit, if different from the current scope, then 12799 -- it is local as well, because it will be replaced at the point of 12800 -- instantiation. On the other hand, if it is a reference to a child 12801 -- unit of a common ancestor, which appears in an instantiation, it is 12802 -- global because it is used to denote a specific compilation unit at 12803 -- the time the instantiations will be analyzed. 12804 12805 procedure Reset_Entity (N : Node_Id); 12806 -- Save semantic information on global entity so that it is not resolved 12807 -- again at instantiation time. 12808 12809 procedure Save_Entity_Descendants (N : Node_Id); 12810 -- Apply Save_Global_References to the two syntactic descendants of 12811 -- non-terminal nodes that carry an Associated_Node and are processed 12812 -- through Reset_Entity. Once the global entity (if any) has been 12813 -- captured together with its type, only two syntactic descendants need 12814 -- to be traversed to complete the processing of the tree rooted at N. 12815 -- This applies to Selected_Components, Expanded_Names, and to Operator 12816 -- nodes. N can also be a character literal, identifier, or operator 12817 -- symbol node, but the call has no effect in these cases. 12818 12819 procedure Save_Global_Defaults (N1, N2 : Node_Id); 12820 -- Default actuals in nested instances must be handled specially 12821 -- because there is no link to them from the original tree. When an 12822 -- actual subprogram is given by a default, we add an explicit generic 12823 -- association for it in the instantiation node. When we save the 12824 -- global references on the name of the instance, we recover the list 12825 -- of generic associations, and add an explicit one to the original 12826 -- generic tree, through which a global actual can be preserved. 12827 -- Similarly, if a child unit is instantiated within a sibling, in the 12828 -- context of the parent, we must preserve the identifier of the parent 12829 -- so that it can be properly resolved in a subsequent instantiation. 12830 12831 procedure Save_Global_Descendant (D : Union_Id); 12832 -- Apply Save_Global_References recursively to the descendents of the 12833 -- current node. 12834 12835 procedure Save_References (N : Node_Id); 12836 -- This is the recursive procedure that does the work, once the 12837 -- enclosing generic scope has been established. 12838 12839 --------------- 12840 -- Is_Global -- 12841 --------------- 12842 12843 function Is_Global (E : Entity_Id) return Boolean is 12844 Se : Entity_Id; 12845 12846 function Is_Instance_Node (Decl : Node_Id) return Boolean; 12847 -- Determine whether the parent node of a reference to a child unit 12848 -- denotes an instantiation or a formal package, in which case the 12849 -- reference to the child unit is global, even if it appears within 12850 -- the current scope (e.g. when the instance appears within the body 12851 -- of an ancestor). 12852 12853 ---------------------- 12854 -- Is_Instance_Node -- 12855 ---------------------- 12856 12857 function Is_Instance_Node (Decl : Node_Id) return Boolean is 12858 begin 12859 return Nkind (Decl) in N_Generic_Instantiation 12860 or else 12861 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 12862 end Is_Instance_Node; 12863 12864 -- Start of processing for Is_Global 12865 12866 begin 12867 if E = Gen_Scope then 12868 return False; 12869 12870 elsif E = Standard_Standard then 12871 return True; 12872 12873 elsif Is_Child_Unit (E) 12874 and then (Is_Instance_Node (Parent (N2)) 12875 or else (Nkind (Parent (N2)) = N_Expanded_Name 12876 and then N2 = Selector_Name (Parent (N2)) 12877 and then 12878 Is_Instance_Node (Parent (Parent (N2))))) 12879 then 12880 return True; 12881 12882 else 12883 Se := Scope (E); 12884 while Se /= Gen_Scope loop 12885 if Se = Standard_Standard then 12886 return True; 12887 else 12888 Se := Scope (Se); 12889 end if; 12890 end loop; 12891 12892 return False; 12893 end if; 12894 end Is_Global; 12895 12896 ------------------ 12897 -- Reset_Entity -- 12898 ------------------ 12899 12900 procedure Reset_Entity (N : Node_Id) is 12901 12902 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 12903 -- If the type of N2 is global to the generic unit, save the type in 12904 -- the generic node. Just as we perform name capture for explicit 12905 -- references within the generic, we must capture the global types 12906 -- of local entities because they may participate in resolution in 12907 -- the instance. 12908 12909 function Top_Ancestor (E : Entity_Id) return Entity_Id; 12910 -- Find the ultimate ancestor of the current unit. If it is not a 12911 -- generic unit, then the name of the current unit in the prefix of 12912 -- an expanded name must be replaced with its generic homonym to 12913 -- ensure that it will be properly resolved in an instance. 12914 12915 --------------------- 12916 -- Set_Global_Type -- 12917 --------------------- 12918 12919 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 12920 Typ : constant Entity_Id := Etype (N2); 12921 12922 begin 12923 Set_Etype (N, Typ); 12924 12925 if Entity (N) /= N2 12926 and then Has_Private_View (Entity (N)) 12927 then 12928 -- If the entity of N is not the associated node, this is a 12929 -- nested generic and it has an associated node as well, whose 12930 -- type is already the full view (see below). Indicate that the 12931 -- original node has a private view. 12932 12933 Set_Has_Private_View (N); 12934 end if; 12935 12936 -- If not a private type, nothing else to do 12937 12938 if not Is_Private_Type (Typ) then 12939 if Is_Array_Type (Typ) 12940 and then Is_Private_Type (Component_Type (Typ)) 12941 then 12942 Set_Has_Private_View (N); 12943 end if; 12944 12945 -- If it is a derivation of a private type in a context where no 12946 -- full view is needed, nothing to do either. 12947 12948 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 12949 null; 12950 12951 -- Otherwise mark the type for flipping and use the full view when 12952 -- available. 12953 12954 else 12955 Set_Has_Private_View (N); 12956 12957 if Present (Full_View (Typ)) then 12958 Set_Etype (N2, Full_View (Typ)); 12959 end if; 12960 end if; 12961 end Set_Global_Type; 12962 12963 ------------------ 12964 -- Top_Ancestor -- 12965 ------------------ 12966 12967 function Top_Ancestor (E : Entity_Id) return Entity_Id is 12968 Par : Entity_Id; 12969 12970 begin 12971 Par := E; 12972 while Is_Child_Unit (Par) loop 12973 Par := Scope (Par); 12974 end loop; 12975 12976 return Par; 12977 end Top_Ancestor; 12978 12979 -- Start of processing for Reset_Entity 12980 12981 begin 12982 N2 := Get_Associated_Node (N); 12983 E := Entity (N2); 12984 12985 if Present (E) then 12986 12987 -- If the node is an entry call to an entry in an enclosing task, 12988 -- it is rewritten as a selected component. No global entity to 12989 -- preserve in this case, since the expansion will be redone in 12990 -- the instance. 12991 12992 if not Nkind_In (E, N_Defining_Identifier, 12993 N_Defining_Character_Literal, 12994 N_Defining_Operator_Symbol) 12995 then 12996 Set_Associated_Node (N, Empty); 12997 Set_Etype (N, Empty); 12998 return; 12999 end if; 13000 13001 -- If the entity is an itype created as a subtype of an access 13002 -- type with a null exclusion restore source entity for proper 13003 -- visibility. The itype will be created anew in the instance. 13004 13005 if Is_Itype (E) 13006 and then Ekind (E) = E_Access_Subtype 13007 and then Is_Entity_Name (N) 13008 and then Chars (Etype (E)) = Chars (N) 13009 then 13010 E := Etype (E); 13011 Set_Entity (N2, E); 13012 Set_Etype (N2, E); 13013 end if; 13014 13015 if Is_Global (E) then 13016 13017 -- If the entity is a package renaming that is the prefix of 13018 -- an expanded name, it has been rewritten as the renamed 13019 -- package, which is necessary semantically but complicates 13020 -- ASIS tree traversal, so we recover the original entity to 13021 -- expose the renaming. Take into account that the context may 13022 -- be a nested generic and that the original node may itself 13023 -- have an associated node. 13024 13025 if Ekind (E) = E_Package 13026 and then Nkind (Parent (N)) = N_Expanded_Name 13027 and then Present (Original_Node (N2)) 13028 and then Present (Entity (Original_Node (N2))) 13029 and then Is_Entity_Name (Entity (Original_Node (N2))) 13030 then 13031 if Is_Global (Entity (Original_Node (N2))) then 13032 N2 := Original_Node (N2); 13033 Set_Associated_Node (N, N2); 13034 Set_Global_Type (N, N2); 13035 13036 else 13037 -- Renaming is local, and will be resolved in instance 13038 13039 Set_Associated_Node (N, Empty); 13040 Set_Etype (N, Empty); 13041 end if; 13042 13043 else 13044 Set_Global_Type (N, N2); 13045 end if; 13046 13047 elsif Nkind (N) = N_Op_Concat 13048 and then Is_Generic_Type (Etype (N2)) 13049 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 13050 or else 13051 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 13052 and then Is_Intrinsic_Subprogram (E) 13053 then 13054 null; 13055 13056 else 13057 -- Entity is local. Mark generic node as unresolved. 13058 -- Note that now it does not have an entity. 13059 13060 Set_Associated_Node (N, Empty); 13061 Set_Etype (N, Empty); 13062 end if; 13063 13064 if Nkind (Parent (N)) in N_Generic_Instantiation 13065 and then N = Name (Parent (N)) 13066 then 13067 Save_Global_Defaults (Parent (N), Parent (N2)); 13068 end if; 13069 13070 elsif Nkind (Parent (N)) = N_Selected_Component 13071 and then Nkind (Parent (N2)) = N_Expanded_Name 13072 then 13073 if Is_Global (Entity (Parent (N2))) then 13074 Change_Selected_Component_To_Expanded_Name (Parent (N)); 13075 Set_Associated_Node (Parent (N), Parent (N2)); 13076 Set_Global_Type (Parent (N), Parent (N2)); 13077 Save_Entity_Descendants (N); 13078 13079 -- If this is a reference to the current generic entity, replace 13080 -- by the name of the generic homonym of the current package. This 13081 -- is because in an instantiation Par.P.Q will not resolve to the 13082 -- name of the instance, whose enclosing scope is not necessarily 13083 -- Par. We use the generic homonym rather that the name of the 13084 -- generic itself because it may be hidden by a local declaration. 13085 13086 elsif In_Open_Scopes (Entity (Parent (N2))) 13087 and then not 13088 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 13089 then 13090 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 13091 Rewrite (Parent (N), 13092 Make_Identifier (Sloc (N), 13093 Chars => 13094 Chars (Generic_Homonym (Entity (Parent (N2)))))); 13095 else 13096 Rewrite (Parent (N), 13097 Make_Identifier (Sloc (N), 13098 Chars => Chars (Selector_Name (Parent (N2))))); 13099 end if; 13100 end if; 13101 13102 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 13103 and then Parent (N) = Name (Parent (Parent (N))) 13104 then 13105 Save_Global_Defaults 13106 (Parent (Parent (N)), Parent (Parent ((N2)))); 13107 end if; 13108 13109 -- A selected component may denote a static constant that has been 13110 -- folded. If the static constant is global to the generic, capture 13111 -- its value. Otherwise the folding will happen in any instantiation. 13112 13113 elsif Nkind (Parent (N)) = N_Selected_Component 13114 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 13115 then 13116 if Present (Entity (Original_Node (Parent (N2)))) 13117 and then Is_Global (Entity (Original_Node (Parent (N2)))) 13118 then 13119 Rewrite (Parent (N), New_Copy (Parent (N2))); 13120 Set_Analyzed (Parent (N), False); 13121 13122 else 13123 null; 13124 end if; 13125 13126 -- A selected component may be transformed into a parameterless 13127 -- function call. If the called entity is global, rewrite the node 13128 -- appropriately, i.e. as an extended name for the global entity. 13129 13130 elsif Nkind (Parent (N)) = N_Selected_Component 13131 and then Nkind (Parent (N2)) = N_Function_Call 13132 and then N = Selector_Name (Parent (N)) 13133 then 13134 if No (Parameter_Associations (Parent (N2))) then 13135 if Is_Global (Entity (Name (Parent (N2)))) then 13136 Change_Selected_Component_To_Expanded_Name (Parent (N)); 13137 Set_Associated_Node (Parent (N), Name (Parent (N2))); 13138 Set_Global_Type (Parent (N), Name (Parent (N2))); 13139 Save_Entity_Descendants (N); 13140 13141 else 13142 Set_Is_Prefixed_Call (Parent (N)); 13143 Set_Associated_Node (N, Empty); 13144 Set_Etype (N, Empty); 13145 end if; 13146 13147 -- In Ada 2005, X.F may be a call to a primitive operation, 13148 -- rewritten as F (X). This rewriting will be done again in an 13149 -- instance, so keep the original node. Global entities will be 13150 -- captured as for other constructs. Indicate that this must 13151 -- resolve as a call, to prevent accidental overloading in the 13152 -- instance, if both a component and a primitive operation appear 13153 -- as candidates. 13154 13155 else 13156 Set_Is_Prefixed_Call (Parent (N)); 13157 end if; 13158 13159 -- Entity is local. Reset in generic unit, so that node is resolved 13160 -- anew at the point of instantiation. 13161 13162 else 13163 Set_Associated_Node (N, Empty); 13164 Set_Etype (N, Empty); 13165 end if; 13166 end Reset_Entity; 13167 13168 ----------------------------- 13169 -- Save_Entity_Descendants -- 13170 ----------------------------- 13171 13172 procedure Save_Entity_Descendants (N : Node_Id) is 13173 begin 13174 case Nkind (N) is 13175 when N_Binary_Op => 13176 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 13177 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 13178 13179 when N_Unary_Op => 13180 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 13181 13182 when N_Expanded_Name | N_Selected_Component => 13183 Save_Global_Descendant (Union_Id (Prefix (N))); 13184 Save_Global_Descendant (Union_Id (Selector_Name (N))); 13185 13186 when N_Identifier | N_Character_Literal | N_Operator_Symbol => 13187 null; 13188 13189 when others => 13190 raise Program_Error; 13191 end case; 13192 end Save_Entity_Descendants; 13193 13194 -------------------------- 13195 -- Save_Global_Defaults -- 13196 -------------------------- 13197 13198 procedure Save_Global_Defaults (N1, N2 : Node_Id) is 13199 Loc : constant Source_Ptr := Sloc (N1); 13200 Assoc2 : constant List_Id := Generic_Associations (N2); 13201 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 13202 Assoc1 : List_Id; 13203 Act1 : Node_Id; 13204 Act2 : Node_Id; 13205 Def : Node_Id; 13206 Ndec : Node_Id; 13207 Subp : Entity_Id; 13208 Actual : Entity_Id; 13209 13210 begin 13211 Assoc1 := Generic_Associations (N1); 13212 13213 if Present (Assoc1) then 13214 Act1 := First (Assoc1); 13215 else 13216 Act1 := Empty; 13217 Set_Generic_Associations (N1, New_List); 13218 Assoc1 := Generic_Associations (N1); 13219 end if; 13220 13221 if Present (Assoc2) then 13222 Act2 := First (Assoc2); 13223 else 13224 return; 13225 end if; 13226 13227 while Present (Act1) and then Present (Act2) loop 13228 Next (Act1); 13229 Next (Act2); 13230 end loop; 13231 13232 -- Find the associations added for default subprograms 13233 13234 if Present (Act2) then 13235 while Nkind (Act2) /= N_Generic_Association 13236 or else No (Entity (Selector_Name (Act2))) 13237 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 13238 loop 13239 Next (Act2); 13240 end loop; 13241 13242 -- Add a similar association if the default is global. The 13243 -- renaming declaration for the actual has been analyzed, and 13244 -- its alias is the program it renames. Link the actual in the 13245 -- original generic tree with the node in the analyzed tree. 13246 13247 while Present (Act2) loop 13248 Subp := Entity (Selector_Name (Act2)); 13249 Def := Explicit_Generic_Actual_Parameter (Act2); 13250 13251 -- Following test is defence against rubbish errors 13252 13253 if No (Alias (Subp)) then 13254 return; 13255 end if; 13256 13257 -- Retrieve the resolved actual from the renaming declaration 13258 -- created for the instantiated formal. 13259 13260 Actual := Entity (Name (Parent (Parent (Subp)))); 13261 Set_Entity (Def, Actual); 13262 Set_Etype (Def, Etype (Actual)); 13263 13264 if Is_Global (Actual) then 13265 Ndec := 13266 Make_Generic_Association (Loc, 13267 Selector_Name => New_Occurrence_Of (Subp, Loc), 13268 Explicit_Generic_Actual_Parameter => 13269 New_Occurrence_Of (Actual, Loc)); 13270 13271 Set_Associated_Node 13272 (Explicit_Generic_Actual_Parameter (Ndec), Def); 13273 13274 Append (Ndec, Assoc1); 13275 13276 -- If there are other defaults, add a dummy association in case 13277 -- there are other defaulted formals with the same name. 13278 13279 elsif Present (Next (Act2)) then 13280 Ndec := 13281 Make_Generic_Association (Loc, 13282 Selector_Name => New_Occurrence_Of (Subp, Loc), 13283 Explicit_Generic_Actual_Parameter => Empty); 13284 13285 Append (Ndec, Assoc1); 13286 end if; 13287 13288 Next (Act2); 13289 end loop; 13290 end if; 13291 13292 if Nkind (Name (N1)) = N_Identifier 13293 and then Is_Child_Unit (Gen_Id) 13294 and then Is_Global (Gen_Id) 13295 and then Is_Generic_Unit (Scope (Gen_Id)) 13296 and then In_Open_Scopes (Scope (Gen_Id)) 13297 then 13298 -- This is an instantiation of a child unit within a sibling, so 13299 -- that the generic parent is in scope. An eventual instance must 13300 -- occur within the scope of an instance of the parent. Make name 13301 -- in instance into an expanded name, to preserve the identifier 13302 -- of the parent, so it can be resolved subsequently. 13303 13304 Rewrite (Name (N2), 13305 Make_Expanded_Name (Loc, 13306 Chars => Chars (Gen_Id), 13307 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 13308 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 13309 Set_Entity (Name (N2), Gen_Id); 13310 13311 Rewrite (Name (N1), 13312 Make_Expanded_Name (Loc, 13313 Chars => Chars (Gen_Id), 13314 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 13315 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 13316 13317 Set_Associated_Node (Name (N1), Name (N2)); 13318 Set_Associated_Node (Prefix (Name (N1)), Empty); 13319 Set_Associated_Node 13320 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 13321 Set_Etype (Name (N1), Etype (Gen_Id)); 13322 end if; 13323 13324 end Save_Global_Defaults; 13325 13326 ---------------------------- 13327 -- Save_Global_Descendant -- 13328 ---------------------------- 13329 13330 procedure Save_Global_Descendant (D : Union_Id) is 13331 N1 : Node_Id; 13332 13333 begin 13334 if D in Node_Range then 13335 if D = Union_Id (Empty) then 13336 null; 13337 13338 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 13339 Save_References (Node_Id (D)); 13340 end if; 13341 13342 elsif D in List_Range then 13343 if D = Union_Id (No_List) 13344 or else Is_Empty_List (List_Id (D)) 13345 then 13346 null; 13347 13348 else 13349 N1 := First (List_Id (D)); 13350 while Present (N1) loop 13351 Save_References (N1); 13352 Next (N1); 13353 end loop; 13354 end if; 13355 13356 -- Element list or other non-node field, nothing to do 13357 13358 else 13359 null; 13360 end if; 13361 end Save_Global_Descendant; 13362 13363 --------------------- 13364 -- Save_References -- 13365 --------------------- 13366 13367 -- This is the recursive procedure that does the work once the enclosing 13368 -- generic scope has been established. We have to treat specially a 13369 -- number of node rewritings that are required by semantic processing 13370 -- and which change the kind of nodes in the generic copy: typically 13371 -- constant-folding, replacing an operator node by a string literal, or 13372 -- a selected component by an expanded name. In each of those cases, the 13373 -- transformation is propagated to the generic unit. 13374 13375 procedure Save_References (N : Node_Id) is 13376 Loc : constant Source_Ptr := Sloc (N); 13377 13378 begin 13379 if N = Empty then 13380 null; 13381 13382 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 13383 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13384 Reset_Entity (N); 13385 13386 elsif Nkind (N) = N_Operator_Symbol 13387 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 13388 then 13389 Change_Operator_Symbol_To_String_Literal (N); 13390 end if; 13391 13392 elsif Nkind (N) in N_Op then 13393 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13394 if Nkind (N) = N_Op_Concat then 13395 Set_Is_Component_Left_Opnd (N, 13396 Is_Component_Left_Opnd (Get_Associated_Node (N))); 13397 13398 Set_Is_Component_Right_Opnd (N, 13399 Is_Component_Right_Opnd (Get_Associated_Node (N))); 13400 end if; 13401 13402 Reset_Entity (N); 13403 13404 else 13405 -- Node may be transformed into call to a user-defined operator 13406 13407 N2 := Get_Associated_Node (N); 13408 13409 if Nkind (N2) = N_Function_Call then 13410 E := Entity (Name (N2)); 13411 13412 if Present (E) 13413 and then Is_Global (E) 13414 then 13415 Set_Etype (N, Etype (N2)); 13416 else 13417 Set_Associated_Node (N, Empty); 13418 Set_Etype (N, Empty); 13419 end if; 13420 13421 elsif Nkind_In (N2, N_Integer_Literal, 13422 N_Real_Literal, 13423 N_String_Literal) 13424 then 13425 if Present (Original_Node (N2)) 13426 and then Nkind (Original_Node (N2)) = Nkind (N) 13427 then 13428 13429 -- Operation was constant-folded. Whenever possible, 13430 -- recover semantic information from unfolded node, 13431 -- for ASIS use. 13432 13433 Set_Associated_Node (N, Original_Node (N2)); 13434 13435 if Nkind (N) = N_Op_Concat then 13436 Set_Is_Component_Left_Opnd (N, 13437 Is_Component_Left_Opnd (Get_Associated_Node (N))); 13438 Set_Is_Component_Right_Opnd (N, 13439 Is_Component_Right_Opnd (Get_Associated_Node (N))); 13440 end if; 13441 13442 Reset_Entity (N); 13443 13444 else 13445 -- If original node is already modified, propagate 13446 -- constant-folding to template. 13447 13448 Rewrite (N, New_Copy (N2)); 13449 Set_Analyzed (N, False); 13450 end if; 13451 13452 elsif Nkind (N2) = N_Identifier 13453 and then Ekind (Entity (N2)) = E_Enumeration_Literal 13454 then 13455 -- Same if call was folded into a literal, but in this case 13456 -- retain the entity to avoid spurious ambiguities if it is 13457 -- overloaded at the point of instantiation or inlining. 13458 13459 Rewrite (N, New_Copy (N2)); 13460 Set_Analyzed (N, False); 13461 end if; 13462 end if; 13463 13464 -- Complete operands check if node has not been constant-folded 13465 13466 if Nkind (N) in N_Op then 13467 Save_Entity_Descendants (N); 13468 end if; 13469 13470 elsif Nkind (N) = N_Identifier then 13471 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13472 13473 -- If this is a discriminant reference, always save it. It is 13474 -- used in the instance to find the corresponding discriminant 13475 -- positionally rather than by name. 13476 13477 Set_Original_Discriminant 13478 (N, Original_Discriminant (Get_Associated_Node (N))); 13479 Reset_Entity (N); 13480 13481 else 13482 N2 := Get_Associated_Node (N); 13483 13484 if Nkind (N2) = N_Function_Call then 13485 E := Entity (Name (N2)); 13486 13487 -- Name resolves to a call to parameterless function. If 13488 -- original entity is global, mark node as resolved. 13489 13490 if Present (E) 13491 and then Is_Global (E) 13492 then 13493 Set_Etype (N, Etype (N2)); 13494 else 13495 Set_Associated_Node (N, Empty); 13496 Set_Etype (N, Empty); 13497 end if; 13498 13499 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 13500 and then Is_Entity_Name (Original_Node (N2)) 13501 then 13502 -- Name resolves to named number that is constant-folded, 13503 -- We must preserve the original name for ASIS use, and 13504 -- undo the constant-folding, which will be repeated in 13505 -- each instance. 13506 13507 Set_Associated_Node (N, Original_Node (N2)); 13508 Reset_Entity (N); 13509 13510 elsif Nkind (N2) = N_String_Literal then 13511 13512 -- Name resolves to string literal. Perform the same 13513 -- replacement in generic. 13514 13515 Rewrite (N, New_Copy (N2)); 13516 13517 elsif Nkind (N2) = N_Explicit_Dereference then 13518 13519 -- An identifier is rewritten as a dereference if it is the 13520 -- prefix in an implicit dereference (call or attribute). 13521 -- The analysis of an instantiation will expand the node 13522 -- again, so we preserve the original tree but link it to 13523 -- the resolved entity in case it is global. 13524 13525 if Is_Entity_Name (Prefix (N2)) 13526 and then Present (Entity (Prefix (N2))) 13527 and then Is_Global (Entity (Prefix (N2))) 13528 then 13529 Set_Associated_Node (N, Prefix (N2)); 13530 13531 elsif Nkind (Prefix (N2)) = N_Function_Call 13532 and then Is_Global (Entity (Name (Prefix (N2)))) 13533 then 13534 Rewrite (N, 13535 Make_Explicit_Dereference (Loc, 13536 Prefix => Make_Function_Call (Loc, 13537 Name => 13538 New_Occurrence_Of (Entity (Name (Prefix (N2))), 13539 Loc)))); 13540 13541 else 13542 Set_Associated_Node (N, Empty); 13543 Set_Etype (N, Empty); 13544 end if; 13545 13546 -- The subtype mark of a nominally unconstrained object is 13547 -- rewritten as a subtype indication using the bounds of the 13548 -- expression. Recover the original subtype mark. 13549 13550 elsif Nkind (N2) = N_Subtype_Indication 13551 and then Is_Entity_Name (Original_Node (N2)) 13552 then 13553 Set_Associated_Node (N, Original_Node (N2)); 13554 Reset_Entity (N); 13555 13556 else 13557 null; 13558 end if; 13559 end if; 13560 13561 elsif Nkind (N) in N_Entity then 13562 null; 13563 13564 else 13565 declare 13566 Qual : Node_Id := Empty; 13567 Typ : Entity_Id := Empty; 13568 Nam : Node_Id; 13569 13570 use Atree.Unchecked_Access; 13571 -- This code section is part of implementing an untyped tree 13572 -- traversal, so it needs direct access to node fields. 13573 13574 begin 13575 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 13576 N2 := Get_Associated_Node (N); 13577 13578 if No (N2) then 13579 Typ := Empty; 13580 else 13581 Typ := Etype (N2); 13582 13583 -- In an instance within a generic, use the name of the 13584 -- actual and not the original generic parameter. If the 13585 -- actual is global in the current generic it must be 13586 -- preserved for its instantiation. 13587 13588 if Nkind (Parent (Typ)) = N_Subtype_Declaration 13589 and then 13590 Present (Generic_Parent_Type (Parent (Typ))) 13591 then 13592 Typ := Base_Type (Typ); 13593 Set_Etype (N2, Typ); 13594 end if; 13595 end if; 13596 13597 if No (N2) 13598 or else No (Typ) 13599 or else not Is_Global (Typ) 13600 then 13601 Set_Associated_Node (N, Empty); 13602 13603 -- If the aggregate is an actual in a call, it has been 13604 -- resolved in the current context, to some local type. 13605 -- The enclosing call may have been disambiguated by the 13606 -- aggregate, and this disambiguation might fail at 13607 -- instantiation time because the type to which the 13608 -- aggregate did resolve is not preserved. In order to 13609 -- preserve some of this information, we wrap the 13610 -- aggregate in a qualified expression, using the id of 13611 -- its type. For further disambiguation we qualify the 13612 -- type name with its scope (if visible) because both 13613 -- id's will have corresponding entities in an instance. 13614 -- This resolves most of the problems with missing type 13615 -- information on aggregates in instances. 13616 13617 if Nkind (N2) = Nkind (N) 13618 and then Nkind (Parent (N2)) in N_Subprogram_Call 13619 and then Comes_From_Source (Typ) 13620 then 13621 if Is_Immediately_Visible (Scope (Typ)) then 13622 Nam := Make_Selected_Component (Loc, 13623 Prefix => 13624 Make_Identifier (Loc, Chars (Scope (Typ))), 13625 Selector_Name => 13626 Make_Identifier (Loc, Chars (Typ))); 13627 else 13628 Nam := Make_Identifier (Loc, Chars (Typ)); 13629 end if; 13630 13631 Qual := 13632 Make_Qualified_Expression (Loc, 13633 Subtype_Mark => Nam, 13634 Expression => Relocate_Node (N)); 13635 end if; 13636 end if; 13637 13638 Save_Global_Descendant (Field1 (N)); 13639 Save_Global_Descendant (Field2 (N)); 13640 Save_Global_Descendant (Field3 (N)); 13641 Save_Global_Descendant (Field5 (N)); 13642 13643 if Present (Qual) then 13644 Rewrite (N, Qual); 13645 end if; 13646 13647 -- All other cases than aggregates 13648 13649 else 13650 Save_Global_Descendant (Field1 (N)); 13651 Save_Global_Descendant (Field2 (N)); 13652 Save_Global_Descendant (Field3 (N)); 13653 Save_Global_Descendant (Field4 (N)); 13654 Save_Global_Descendant (Field5 (N)); 13655 end if; 13656 end; 13657 end if; 13658 13659 -- If a node has aspects, references within their expressions must 13660 -- be saved separately, given that they are not directly in the 13661 -- tree. 13662 13663 if Has_Aspects (N) then 13664 declare 13665 Aspect : Node_Id; 13666 begin 13667 Aspect := First (Aspect_Specifications (N)); 13668 while Present (Aspect) loop 13669 Save_Global_References (Expression (Aspect)); 13670 Next (Aspect); 13671 end loop; 13672 end; 13673 end if; 13674 end Save_References; 13675 13676 -- Start of processing for Save_Global_References 13677 13678 begin 13679 Gen_Scope := Current_Scope; 13680 13681 -- If the generic unit is a child unit, references to entities in the 13682 -- parent are treated as local, because they will be resolved anew in 13683 -- the context of the instance of the parent. 13684 13685 while Is_Child_Unit (Gen_Scope) 13686 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 13687 loop 13688 Gen_Scope := Scope (Gen_Scope); 13689 end loop; 13690 13691 Save_References (N); 13692 end Save_Global_References; 13693 13694 -------------------------------------- 13695 -- Set_Copied_Sloc_For_Inlined_Body -- 13696 -------------------------------------- 13697 13698 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 13699 begin 13700 Create_Instantiation_Source (N, E, True, S_Adjustment); 13701 end Set_Copied_Sloc_For_Inlined_Body; 13702 13703 --------------------- 13704 -- Set_Instance_Of -- 13705 --------------------- 13706 13707 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 13708 begin 13709 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 13710 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 13711 Generic_Renamings.Increment_Last; 13712 end Set_Instance_Of; 13713 13714 -------------------- 13715 -- Set_Next_Assoc -- 13716 -------------------- 13717 13718 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 13719 begin 13720 Generic_Renamings.Table (E).Next_In_HTable := Next; 13721 end Set_Next_Assoc; 13722 13723 ------------------- 13724 -- Start_Generic -- 13725 ------------------- 13726 13727 procedure Start_Generic is 13728 begin 13729 -- ??? More things could be factored out in this routine. 13730 -- Should probably be done at a later stage. 13731 13732 Generic_Flags.Append (Inside_A_Generic); 13733 Inside_A_Generic := True; 13734 13735 Expander_Mode_Save_And_Set (False); 13736 end Start_Generic; 13737 13738 ---------------------- 13739 -- Set_Instance_Env -- 13740 ---------------------- 13741 13742 procedure Set_Instance_Env 13743 (Gen_Unit : Entity_Id; 13744 Act_Unit : Entity_Id) 13745 is 13746 begin 13747 -- Regardless of the current mode, predefined units are analyzed in the 13748 -- most current Ada mode, and earlier version Ada checks do not apply 13749 -- to predefined units. Nothing needs to be done for non-internal units. 13750 -- These are always analyzed in the current mode. 13751 13752 if Is_Internal_File_Name 13753 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), 13754 Renamings_Included => True) 13755 then 13756 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); 13757 end if; 13758 13759 Current_Instantiated_Parent := 13760 (Gen_Id => Gen_Unit, 13761 Act_Id => Act_Unit, 13762 Next_In_HTable => Assoc_Null); 13763 end Set_Instance_Env; 13764 13765 ----------------- 13766 -- Switch_View -- 13767 ----------------- 13768 13769 procedure Switch_View (T : Entity_Id) is 13770 BT : constant Entity_Id := Base_Type (T); 13771 Priv_Elmt : Elmt_Id := No_Elmt; 13772 Priv_Sub : Entity_Id; 13773 13774 begin 13775 -- T may be private but its base type may have been exchanged through 13776 -- some other occurrence, in which case there is nothing to switch 13777 -- besides T itself. Note that a private dependent subtype of a private 13778 -- type might not have been switched even if the base type has been, 13779 -- because of the last branch of Check_Private_View (see comment there). 13780 13781 if not Is_Private_Type (BT) then 13782 Prepend_Elmt (Full_View (T), Exchanged_Views); 13783 Exchange_Declarations (T); 13784 return; 13785 end if; 13786 13787 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 13788 13789 if Present (Full_View (BT)) then 13790 Prepend_Elmt (Full_View (BT), Exchanged_Views); 13791 Exchange_Declarations (BT); 13792 end if; 13793 13794 while Present (Priv_Elmt) loop 13795 Priv_Sub := (Node (Priv_Elmt)); 13796 13797 -- We avoid flipping the subtype if the Etype of its full view is 13798 -- private because this would result in a malformed subtype. This 13799 -- occurs when the Etype of the subtype full view is the full view of 13800 -- the base type (and since the base types were just switched, the 13801 -- subtype is pointing to the wrong view). This is currently the case 13802 -- for tagged record types, access types (maybe more?) and needs to 13803 -- be resolved. ??? 13804 13805 if Present (Full_View (Priv_Sub)) 13806 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 13807 then 13808 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 13809 Exchange_Declarations (Priv_Sub); 13810 end if; 13811 13812 Next_Elmt (Priv_Elmt); 13813 end loop; 13814 end Switch_View; 13815 13816 ----------------- 13817 -- True_Parent -- 13818 ----------------- 13819 13820 function True_Parent (N : Node_Id) return Node_Id is 13821 begin 13822 if Nkind (Parent (N)) = N_Subunit then 13823 return Parent (Corresponding_Stub (Parent (N))); 13824 else 13825 return Parent (N); 13826 end if; 13827 end True_Parent; 13828 13829 ----------------------------- 13830 -- Valid_Default_Attribute -- 13831 ----------------------------- 13832 13833 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 13834 Attr_Id : constant Attribute_Id := 13835 Get_Attribute_Id (Attribute_Name (Def)); 13836 T : constant Entity_Id := Entity (Prefix (Def)); 13837 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 13838 F : Entity_Id; 13839 Num_F : Int; 13840 OK : Boolean; 13841 13842 begin 13843 if No (T) 13844 or else T = Any_Id 13845 then 13846 return; 13847 end if; 13848 13849 Num_F := 0; 13850 F := First_Formal (Nam); 13851 while Present (F) loop 13852 Num_F := Num_F + 1; 13853 Next_Formal (F); 13854 end loop; 13855 13856 case Attr_Id is 13857 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign | 13858 Attribute_Floor | Attribute_Fraction | Attribute_Machine | 13859 Attribute_Model | Attribute_Remainder | Attribute_Rounding | 13860 Attribute_Unbiased_Rounding => 13861 OK := Is_Fun 13862 and then Num_F = 1 13863 and then Is_Floating_Point_Type (T); 13864 13865 when Attribute_Image | Attribute_Pred | Attribute_Succ | 13866 Attribute_Value | Attribute_Wide_Image | 13867 Attribute_Wide_Value => 13868 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T)); 13869 13870 when Attribute_Max | Attribute_Min => 13871 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T)); 13872 13873 when Attribute_Input => 13874 OK := (Is_Fun and then Num_F = 1); 13875 13876 when Attribute_Output | Attribute_Read | Attribute_Write => 13877 OK := (not Is_Fun and then Num_F = 2); 13878 13879 when others => 13880 OK := False; 13881 end case; 13882 13883 if not OK then 13884 Error_Msg_N ("attribute reference has wrong profile for subprogram", 13885 Def); 13886 end if; 13887 end Valid_Default_Attribute; 13888 13889end Sem_Ch12; 13890