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; 79with Warnsw; use Warnsw; 80 81with GNAT.HTable; 82 83package body Sem_Ch12 is 84 85 ---------------------------------------------------------- 86 -- Implementation of Generic Analysis and Instantiation -- 87 ---------------------------------------------------------- 88 89 -- GNAT implements generics by macro expansion. No attempt is made to share 90 -- generic instantiations (for now). Analysis of a generic definition does 91 -- not perform any expansion action, but the expander must be called on the 92 -- tree for each instantiation, because the expansion may of course depend 93 -- on the generic actuals. All of this is best achieved as follows: 94 -- 95 -- a) Semantic analysis of a generic unit is performed on a copy of the 96 -- tree for the generic unit. All tree modifications that follow analysis 97 -- do not affect the original tree. Links are kept between the original 98 -- tree and the copy, in order to recognize non-local references within 99 -- the generic, and propagate them to each instance (recall that name 100 -- resolution is done on the generic declaration: generics are not really 101 -- macros). This is summarized in the following diagram: 102 103 -- .-----------. .----------. 104 -- | semantic |<--------------| generic | 105 -- | copy | | unit | 106 -- | |==============>| | 107 -- |___________| global |__________| 108 -- references | | | 109 -- | | | 110 -- .-----|--|. 111 -- | .-----|---. 112 -- | | .----------. 113 -- | | | generic | 114 -- |__| | | 115 -- |__| instance | 116 -- |__________| 117 118 -- b) Each instantiation copies the original tree, and inserts into it a 119 -- series of declarations that describe the mapping between generic formals 120 -- and actuals. For example, a generic In OUT parameter is an object 121 -- renaming of the corresponding actual, etc. Generic IN parameters are 122 -- constant declarations. 123 124 -- c) In order to give the right visibility for these renamings, we use 125 -- a different scheme for package and subprogram instantiations. For 126 -- packages, the list of renamings is inserted into the package 127 -- specification, before the visible declarations of the package. The 128 -- renamings are analyzed before any of the text of the instance, and are 129 -- thus visible at the right place. Furthermore, outside of the instance, 130 -- the generic parameters are visible and denote their corresponding 131 -- actuals. 132 133 -- For subprograms, we create a container package to hold the renamings 134 -- and the subprogram instance itself. Analysis of the package makes the 135 -- renaming declarations visible to the subprogram. After analyzing the 136 -- package, the defining entity for the subprogram is touched-up so that 137 -- it appears declared in the current scope, and not inside the container 138 -- package. 139 140 -- If the instantiation is a compilation unit, the container package is 141 -- given the same name as the subprogram instance. This ensures that 142 -- the elaboration procedure called by the binder, using the compilation 143 -- unit name, calls in fact the elaboration procedure for the package. 144 145 -- Not surprisingly, private types complicate this approach. By saving in 146 -- the original generic object the non-local references, we guarantee that 147 -- the proper entities are referenced at the point of instantiation. 148 -- However, for private types, this by itself does not insure that the 149 -- proper VIEW of the entity is used (the full type may be visible at the 150 -- point of generic definition, but not at instantiation, or vice-versa). 151 -- In order to reference the proper view, we special-case any reference 152 -- to private types in the generic object, by saving both views, one in 153 -- the generic and one in the semantic copy. At time of instantiation, we 154 -- check whether the two views are consistent, and exchange declarations if 155 -- necessary, in order to restore the correct visibility. Similarly, if 156 -- the instance view is private when the generic view was not, we perform 157 -- the exchange. After completing the instantiation, we restore the 158 -- current visibility. The flag Has_Private_View marks identifiers in the 159 -- the generic unit that require checking. 160 161 -- Visibility within nested generic units requires special handling. 162 -- Consider the following scheme: 163 164 -- type Global is ... -- outside of generic unit. 165 -- generic ... 166 -- package Outer is 167 -- ... 168 -- type Semi_Global is ... -- global to inner. 169 170 -- generic ... -- 1 171 -- procedure inner (X1 : Global; X2 : Semi_Global); 172 173 -- procedure in2 is new inner (...); -- 4 174 -- end Outer; 175 176 -- package New_Outer is new Outer (...); -- 2 177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3 178 179 -- The semantic analysis of Outer captures all occurrences of Global. 180 -- The semantic analysis of Inner (at 1) captures both occurrences of 181 -- Global and Semi_Global. 182 183 -- At point 2 (instantiation of Outer), we also produce a generic copy 184 -- of Inner, even though Inner is, at that point, not being instantiated. 185 -- (This is just part of the semantic analysis of New_Outer). 186 187 -- Critically, references to Global within Inner must be preserved, while 188 -- references to Semi_Global should not preserved, because they must now 189 -- resolve to an entity within New_Outer. To distinguish between these, we 190 -- use a global variable, Current_Instantiated_Parent, which is set when 191 -- performing a generic copy during instantiation (at 2). This variable is 192 -- used when performing a generic copy that is not an instantiation, but 193 -- that is nested within one, as the occurrence of 1 within 2. The analysis 194 -- of a nested generic only preserves references that are global to the 195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to 196 -- determine whether a reference is external to the given parent. 197 198 -- The instantiation at point 3 requires no special treatment. The method 199 -- works as well for further nestings of generic units, but of course the 200 -- variable Current_Instantiated_Parent must be stacked because nested 201 -- instantiations can occur, e.g. the occurrence of 4 within 2. 202 203 -- The instantiation of package and subprogram bodies is handled in a 204 -- similar manner, except that it is delayed until after semantic 205 -- analysis is complete. In this fashion complex cross-dependencies 206 -- between several package declarations and bodies containing generics 207 -- can be compiled which otherwise would diagnose spurious circularities. 208 209 -- For example, it is possible to compile two packages A and B that 210 -- have the following structure: 211 212 -- package A is package B is 213 -- generic ... generic ... 214 -- package G_A is package G_B is 215 216 -- with B; with A; 217 -- package body A is package body B is 218 -- package N_B is new G_B (..) package N_A is new G_A (..) 219 220 -- The table Pending_Instantiations in package Inline is used to keep 221 -- track of body instantiations that are delayed in this manner. Inline 222 -- handles the actual calls to do the body instantiations. This activity 223 -- is part of Inline, since the processing occurs at the same point, and 224 -- for essentially the same reason, as the handling of inlined routines. 225 226 ---------------------------------------------- 227 -- Detection of Instantiation Circularities -- 228 ---------------------------------------------- 229 230 -- If we have a chain of instantiations that is circular, this is static 231 -- error which must be detected at compile time. The detection of these 232 -- circularities is carried out at the point that we insert a generic 233 -- instance spec or body. If there is a circularity, then the analysis of 234 -- the offending spec or body will eventually result in trying to load the 235 -- same unit again, and we detect this problem as we analyze the package 236 -- instantiation for the second time. 237 238 -- At least in some cases after we have detected the circularity, we get 239 -- into trouble if we try to keep going. The following flag is set if a 240 -- circularity is detected, and used to abandon compilation after the 241 -- messages have been posted. 242 243 Circularity_Detected : Boolean := False; 244 -- This should really be reset on encountering a new main unit, but in 245 -- practice we are not using multiple main units so it is not critical. 246 247 -------------------------------------------------- 248 -- Formal packages and partial parameterization -- 249 -------------------------------------------------- 250 251 -- When compiling a generic, a formal package is a local instantiation. If 252 -- declared with a box, its generic formals are visible in the enclosing 253 -- generic. If declared with a partial list of actuals, those actuals that 254 -- are defaulted (covered by an Others clause, or given an explicit box 255 -- initialization) are also visible in the enclosing generic, while those 256 -- that have a corresponding actual are not. 257 258 -- In our source model of instantiation, the same visibility must be 259 -- present in the spec and body of an instance: the names of the formals 260 -- that are defaulted must be made visible within the instance, and made 261 -- invisible (hidden) after the instantiation is complete, so that they 262 -- are not accessible outside of the instance. 263 264 -- In a generic, a formal package is treated like a special instantiation. 265 -- Our Ada 95 compiler handled formals with and without box in different 266 -- ways. With partial parameterization, we use a single model for both. 267 -- We create a package declaration that consists of the specification of 268 -- the generic package, and a set of declarations that map the actuals 269 -- into local renamings, just as we do for bona fide instantiations. For 270 -- defaulted parameters and formals with a box, we copy directly the 271 -- declarations of the formal into this local package. The result is a 272 -- a package whose visible declarations may include generic formals. This 273 -- package is only used for type checking and visibility analysis, and 274 -- never reaches the back-end, so it can freely violate the placement 275 -- rules for generic formal declarations. 276 277 -- The list of declarations (renamings and copies of formals) is built 278 -- by Analyze_Associations, just as for regular instantiations. 279 280 -- At the point of instantiation, conformance checking must be applied only 281 -- to those parameters that were specified in the formal. We perform this 282 -- checking by creating another internal instantiation, this one including 283 -- only the renamings and the formals (the rest of the package spec is not 284 -- relevant to conformance checking). We can then traverse two lists: the 285 -- list of actuals in the instance that corresponds to the formal package, 286 -- and the list of actuals produced for this bogus instantiation. We apply 287 -- the conformance rules to those actuals that are not defaulted (i.e. 288 -- which still appear as generic formals. 289 290 -- When we compile an instance body we must make the right parameters 291 -- visible again. The predicate Is_Generic_Formal indicates which of the 292 -- formals should have its Is_Hidden flag reset. 293 294 ----------------------- 295 -- Local subprograms -- 296 ----------------------- 297 298 procedure Abandon_Instantiation (N : Node_Id); 299 pragma No_Return (Abandon_Instantiation); 300 -- Posts an error message "instantiation abandoned" at the indicated node 301 -- and then raises the exception Instantiation_Error to do it. 302 303 procedure Analyze_Formal_Array_Type 304 (T : in out Entity_Id; 305 Def : Node_Id); 306 -- A formal array type is treated like an array type declaration, and 307 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is 308 -- in-out, because in the case of an anonymous type the entity is 309 -- actually created in the procedure. 310 311 -- The following procedures treat other kinds of formal parameters 312 313 procedure Analyze_Formal_Derived_Interface_Type 314 (N : Node_Id; 315 T : Entity_Id; 316 Def : Node_Id); 317 318 procedure Analyze_Formal_Derived_Type 319 (N : Node_Id; 320 T : Entity_Id; 321 Def : Node_Id); 322 323 procedure Analyze_Formal_Interface_Type 324 (N : Node_Id; 325 T : Entity_Id; 326 Def : Node_Id); 327 328 -- The following subprograms create abbreviated declarations for formal 329 -- scalar types. We introduce an anonymous base of the proper class for 330 -- each of them, and define the formals as constrained first subtypes of 331 -- their bases. The bounds are expressions that are non-static in the 332 -- generic. 333 334 procedure Analyze_Formal_Decimal_Fixed_Point_Type 335 (T : Entity_Id; Def : Node_Id); 336 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); 337 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); 338 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); 339 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); 340 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 341 (T : Entity_Id; Def : Node_Id); 342 343 procedure Analyze_Formal_Private_Type 344 (N : Node_Id; 345 T : Entity_Id; 346 Def : Node_Id); 347 -- Creates a new private type, which does not require completion 348 349 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); 350 -- Ada 2012: Creates a new incomplete type whose actual does not freeze 351 352 procedure Analyze_Generic_Formal_Part (N : Node_Id); 353 -- Analyze generic formal part 354 355 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); 356 -- Create a new access type with the given designated type 357 358 function Analyze_Associations 359 (I_Node : Node_Id; 360 Formals : List_Id; 361 F_Copy : List_Id) return List_Id; 362 -- At instantiation time, build the list of associations between formals 363 -- and actuals. Each association becomes a renaming declaration for the 364 -- formal entity. F_Copy is the analyzed list of formals in the generic 365 -- copy. It is used to apply legality checks to the actuals. I_Node is the 366 -- instantiation node itself. 367 368 procedure Analyze_Subprogram_Instantiation 369 (N : Node_Id; 370 K : Entity_Kind); 371 372 procedure Build_Instance_Compilation_Unit_Nodes 373 (N : Node_Id; 374 Act_Body : Node_Id; 375 Act_Decl : Node_Id); 376 -- This procedure is used in the case where the generic instance of a 377 -- subprogram body or package body is a library unit. In this case, the 378 -- original library unit node for the generic instantiation must be 379 -- replaced by the resulting generic body, and a link made to a new 380 -- compilation unit node for the generic declaration. The argument N is 381 -- the original generic instantiation. Act_Body and Act_Decl are the body 382 -- and declaration of the instance (either package body and declaration 383 -- nodes or subprogram body and declaration nodes depending on the case). 384 -- On return, the node N has been rewritten with the actual body. 385 386 procedure Check_Access_Definition (N : Node_Id); 387 -- Subsidiary routine to null exclusion processing. Perform an assertion 388 -- check on Ada version and the presence of an access definition in N. 389 390 procedure Check_Formal_Packages (P_Id : Entity_Id); 391 -- Apply the following to all formal packages in generic associations 392 393 procedure Check_Formal_Package_Instance 394 (Formal_Pack : Entity_Id; 395 Actual_Pack : Entity_Id); 396 -- Verify that the actuals of the actual instance match the actuals of 397 -- the template for a formal package that is not declared with a box. 398 399 procedure Check_Forward_Instantiation (Decl : Node_Id); 400 -- If the generic is a local entity and the corresponding body has not 401 -- been seen yet, flag enclosing packages to indicate that it will be 402 -- elaborated after the generic body. Subprograms declared in the same 403 -- package cannot be inlined by the front-end because front-end inlining 404 -- requires a strict linear order of elaboration. 405 406 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; 407 -- Check if some association between formals and actuals requires to make 408 -- visible primitives of a tagged type, and make those primitives visible. 409 -- Return the list of primitives whose visibility is modified (to restore 410 -- their visibility later through Restore_Hidden_Primitives). If no 411 -- candidate is found then return No_Elist. 412 413 procedure Check_Hidden_Child_Unit 414 (N : Node_Id; 415 Gen_Unit : Entity_Id; 416 Act_Decl_Id : Entity_Id); 417 -- If the generic unit is an implicit child instance within a parent 418 -- instance, we need to make an explicit test that it is not hidden by 419 -- a child instance of the same name and parent. 420 421 procedure Check_Generic_Actuals 422 (Instance : Entity_Id; 423 Is_Formal_Box : Boolean); 424 -- Similar to previous one. Check the actuals in the instantiation, 425 -- whose views can change between the point of instantiation and the point 426 -- of instantiation of the body. In addition, mark the generic renamings 427 -- as generic actuals, so that they are not compatible with other actuals. 428 -- Recurse on an actual that is a formal package whose declaration has 429 -- a box. 430 431 function Contains_Instance_Of 432 (Inner : Entity_Id; 433 Outer : Entity_Id; 434 N : Node_Id) return Boolean; 435 -- Inner is instantiated within the generic Outer. Check whether Inner 436 -- directly or indirectly contains an instance of Outer or of one of its 437 -- parents, in the case of a subunit. Each generic unit holds a list of 438 -- the entities instantiated within (at any depth). This procedure 439 -- determines whether the set of such lists contains a cycle, i.e. an 440 -- illegal circular instantiation. 441 442 function Denotes_Formal_Package 443 (Pack : Entity_Id; 444 On_Exit : Boolean := False; 445 Instance : Entity_Id := Empty) return Boolean; 446 -- Returns True if E is a formal package of an enclosing generic, or 447 -- the actual for such a formal in an enclosing instantiation. If such 448 -- a package is used as a formal in an nested generic, or as an actual 449 -- in a nested instantiation, the visibility of ITS formals should not 450 -- be modified. When called from within Restore_Private_Views, the flag 451 -- On_Exit is true, to indicate that the search for a possible enclosing 452 -- instance should ignore the current one. In that case Instance denotes 453 -- the declaration for which this is an actual. This declaration may be 454 -- an instantiation in the source, or the internal instantiation that 455 -- corresponds to the actual for a formal package. 456 457 function Earlier (N1, N2 : Node_Id) return Boolean; 458 -- Yields True if N1 and N2 appear in the same compilation unit, 459 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right 460 -- traversal of the tree for the unit. Used to determine the placement 461 -- of freeze nodes for instance bodies that may depend on other instances. 462 463 function Find_Actual_Type 464 (Typ : Entity_Id; 465 Gen_Type : Entity_Id) return Entity_Id; 466 -- When validating the actual types of a child instance, check whether 467 -- the formal is a formal type of the parent unit, and retrieve the current 468 -- actual for it. Typ is the entity in the analyzed formal type declaration 469 -- (component or index type of an array type, or designated type of an 470 -- access formal) and Gen_Type is the enclosing analyzed formal array 471 -- or access type. The desired actual may be a formal of a parent, or may 472 -- be declared in a formal package of a parent. In both cases it is a 473 -- generic actual type because it appears within a visible instance. 474 -- Finally, it may be declared in a parent unit without being a formal 475 -- of that unit, in which case it must be retrieved by visibility. 476 -- Ambiguities may still arise if two homonyms are declared in two formal 477 -- packages, and the prefix of the formal type may be needed to resolve 478 -- the ambiguity in the instance ??? 479 480 function In_Same_Declarative_Part 481 (F_Node : Node_Id; 482 Inst : Node_Id) return Boolean; 483 -- True if the instantiation Inst and the given freeze_node F_Node appear 484 -- within the same declarative part, ignoring subunits, but with no inter- 485 -- vening subprograms or concurrent units. Used to find the proper plave 486 -- for the freeze node of an instance, when the generic is declared in a 487 -- previous instance. If predicate is true, the freeze node of the instance 488 -- can be placed after the freeze node of the previous instance, Otherwise 489 -- it has to be placed at the end of the current declarative part. 490 491 function In_Main_Context (E : Entity_Id) return Boolean; 492 -- Check whether an instantiation is in the context of the main unit. 493 -- Used to determine whether its body should be elaborated to allow 494 -- front-end inlining. 495 496 procedure Set_Instance_Env 497 (Gen_Unit : Entity_Id; 498 Act_Unit : Entity_Id); 499 -- Save current instance on saved environment, to be used to determine 500 -- the global status of entities in nested instances. Part of Save_Env. 501 -- called after verifying that the generic unit is legal for the instance, 502 -- The procedure also examines whether the generic unit is a predefined 503 -- unit, in order to set configuration switches accordingly. As a result 504 -- the procedure must be called after analyzing and freezing the actuals. 505 506 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 507 -- Associate analyzed generic parameter with corresponding 508 -- instance. Used for semantic checks at instantiation time. 509 510 function Has_Been_Exchanged (E : Entity_Id) return Boolean; 511 -- Traverse the Exchanged_Views list to see if a type was private 512 -- and has already been flipped during this phase of instantiation. 513 514 procedure Hide_Current_Scope; 515 -- When instantiating a generic child unit, the parent context must be 516 -- present, but the instance and all entities that may be generated 517 -- must be inserted in the current scope. We leave the current scope 518 -- on the stack, but make its entities invisible to avoid visibility 519 -- problems. This is reversed at the end of the instantiation. This is 520 -- not done for the instantiation of the bodies, which only require the 521 -- instances of the generic parents to be in scope. 522 523 procedure Install_Body 524 (Act_Body : Node_Id; 525 N : Node_Id; 526 Gen_Body : Node_Id; 527 Gen_Decl : Node_Id); 528 -- If the instantiation happens textually before the body of the generic, 529 -- the instantiation of the body must be analyzed after the generic body, 530 -- and not at the point of instantiation. Such early instantiations can 531 -- happen if the generic and the instance appear in a package declaration 532 -- because the generic body can only appear in the corresponding package 533 -- body. Early instantiations can also appear if generic, instance and 534 -- body are all in the declarative part of a subprogram or entry. Entities 535 -- of packages that are early instantiations are delayed, and their freeze 536 -- node appears after the generic body. 537 538 procedure Insert_Freeze_Node_For_Instance 539 (N : Node_Id; 540 F_Node : Node_Id); 541 -- N denotes a package or a subprogram instantiation and F_Node is the 542 -- associated freeze node. Insert the freeze node before the first source 543 -- body which follows immediately after N. If no such body is found, the 544 -- freeze node is inserted at the end of the declarative region which 545 -- contains N. 546 547 procedure Freeze_Subprogram_Body 548 (Inst_Node : Node_Id; 549 Gen_Body : Node_Id; 550 Pack_Id : Entity_Id); 551 -- The generic body may appear textually after the instance, including 552 -- in the proper body of a stub, or within a different package instance. 553 -- Given that the instance can only be elaborated after the generic, we 554 -- place freeze_nodes for the instance and/or for packages that may enclose 555 -- the instance and the generic, so that the back-end can establish the 556 -- proper order of elaboration. 557 558 procedure Init_Env; 559 -- Establish environment for subsequent instantiation. Separated from 560 -- Save_Env because data-structures for visibility handling must be 561 -- initialized before call to Check_Generic_Child_Unit. 562 563 procedure Install_Formal_Packages (Par : Entity_Id); 564 -- Install the visible part of any formal of the parent that is a formal 565 -- package. Note that for the case of a formal package with a box, this 566 -- includes the formal part of the formal package (12.7(10/2)). 567 568 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 569 -- When compiling an instance of a child unit the parent (which is 570 -- itself an instance) is an enclosing scope that must be made 571 -- immediately visible. This procedure is also used to install the non- 572 -- generic parent of a generic child unit when compiling its body, so 573 -- that full views of types in the parent are made visible. 574 575 procedure Remove_Parent (In_Body : Boolean := False); 576 -- Reverse effect after instantiation of child is complete 577 578 procedure Install_Hidden_Primitives 579 (Prims_List : in out Elist_Id; 580 Gen_T : Entity_Id; 581 Act_T : Entity_Id); 582 -- Remove suffix 'P' from hidden primitives of Act_T to match the 583 -- visibility of primitives of Gen_T. The list of primitives to which 584 -- the suffix is removed is added to Prims_List to restore them later. 585 586 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 587 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 588 -- set to No_Elist. 589 590 procedure Inline_Instance_Body 591 (N : Node_Id; 592 Gen_Unit : Entity_Id; 593 Act_Decl : Node_Id); 594 -- If front-end inlining is requested, instantiate the package body, 595 -- and preserve the visibility of its compilation unit, to insure 596 -- that successive instantiations succeed. 597 598 -- The functions Instantiate_XXX perform various legality checks and build 599 -- the declarations for instantiated generic parameters. In all of these 600 -- Formal is the entity in the generic unit, Actual is the entity of 601 -- expression in the generic associations, and Analyzed_Formal is the 602 -- formal in the generic copy, which contains the semantic information to 603 -- be used to validate the actual. 604 605 function Instantiate_Object 606 (Formal : Node_Id; 607 Actual : Node_Id; 608 Analyzed_Formal : Node_Id) return List_Id; 609 610 function Instantiate_Type 611 (Formal : Node_Id; 612 Actual : Node_Id; 613 Analyzed_Formal : Node_Id; 614 Actual_Decls : List_Id) return List_Id; 615 616 function Instantiate_Formal_Subprogram 617 (Formal : Node_Id; 618 Actual : Node_Id; 619 Analyzed_Formal : Node_Id) return Node_Id; 620 621 function Instantiate_Formal_Package 622 (Formal : Node_Id; 623 Actual : Node_Id; 624 Analyzed_Formal : Node_Id) return List_Id; 625 -- If the formal package is declared with a box, special visibility rules 626 -- apply to its formals: they are in the visible part of the package. This 627 -- is true in the declarative region of the formal package, that is to say 628 -- in the enclosing generic or instantiation. For an instantiation, the 629 -- parameters of the formal package are made visible in an explicit step. 630 -- Furthermore, if the actual has a visible USE clause, these formals must 631 -- be made potentially use-visible as well. On exit from the enclosing 632 -- instantiation, the reverse must be done. 633 634 -- For a formal package declared without a box, there are conformance rules 635 -- that apply to the actuals in the generic declaration and the actuals of 636 -- the actual package in the enclosing instantiation. The simplest way to 637 -- apply these rules is to repeat the instantiation of the formal package 638 -- in the context of the enclosing instance, and compare the generic 639 -- associations of this instantiation with those of the actual package. 640 -- This internal instantiation only needs to contain the renamings of the 641 -- formals: the visible and private declarations themselves need not be 642 -- created. 643 644 -- In Ada 2005, the formal package may be only partially parameterized. 645 -- In that case the visibility step must make visible those actuals whose 646 -- corresponding formals were given with a box. A final complication 647 -- involves inherited operations from formal derived types, which must 648 -- be visible if the type is. 649 650 function Is_In_Main_Unit (N : Node_Id) return Boolean; 651 -- Test if given node is in the main unit 652 653 procedure Load_Parent_Of_Generic 654 (N : Node_Id; 655 Spec : Node_Id; 656 Body_Optional : Boolean := False); 657 -- If the generic appears in a separate non-generic library unit, load the 658 -- corresponding body to retrieve the body of the generic. N is the node 659 -- for the generic instantiation, Spec is the generic package declaration. 660 -- 661 -- Body_Optional is a flag that indicates that the body is being loaded to 662 -- ensure that temporaries are generated consistently when there are other 663 -- instances in the current declarative part that precede the one being 664 -- loaded. In that case a missing body is acceptable. 665 666 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); 667 -- Add the context clause of the unit containing a generic unit to a 668 -- compilation unit that is, or contains, an instantiation. 669 670 function Get_Associated_Node (N : Node_Id) return Node_Id; 671 -- In order to propagate semantic information back from the analyzed copy 672 -- to the original generic, we maintain links between selected nodes in the 673 -- generic and their corresponding copies. At the end of generic analysis, 674 -- the routine Save_Global_References traverses the generic tree, examines 675 -- the semantic information, and preserves the links to those nodes that 676 -- contain global information. At instantiation, the information from the 677 -- associated node is placed on the new copy, so that name resolution is 678 -- not repeated. 679 -- 680 -- Three kinds of source nodes have associated nodes: 681 -- 682 -- a) those that can reference (denote) entities, that is identifiers, 683 -- character literals, expanded_names, operator symbols, operators, 684 -- and attribute reference nodes. These nodes have an Entity field 685 -- and are the set of nodes that are in N_Has_Entity. 686 -- 687 -- b) aggregates (N_Aggregate and N_Extension_Aggregate) 688 -- 689 -- c) selected components (N_Selected_Component) 690 -- 691 -- For the first class, the associated node preserves the entity if it is 692 -- global. If the generic contains nested instantiations, the associated 693 -- node itself has been recopied, and a chain of them must be followed. 694 -- 695 -- For aggregates, the associated node allows retrieval of the type, which 696 -- may otherwise not appear in the generic. The view of this type may be 697 -- different between generic and instantiation, and the full view can be 698 -- installed before the instantiation is analyzed. For aggregates of type 699 -- extensions, the same view exchange may have to be performed for some of 700 -- the ancestor types, if their view is private at the point of 701 -- instantiation. 702 -- 703 -- Nodes that are selected components in the parse tree may be rewritten 704 -- as expanded names after resolution, and must be treated as potential 705 -- entity holders, which is why they also have an Associated_Node. 706 -- 707 -- Nodes that do not come from source, such as freeze nodes, do not appear 708 -- in the generic tree, and need not have an associated node. 709 -- 710 -- The associated node is stored in the Associated_Node field. Note that 711 -- this field overlaps Entity, which is fine, because the whole point is 712 -- that we don't need or want the normal Entity field in this situation. 713 714 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 715 -- Within the generic part, entities in the formal package are 716 -- visible. To validate subsequent type declarations, indicate 717 -- the correspondence between the entities in the analyzed formal, 718 -- and the entities in the actual package. There are three packages 719 -- involved in the instantiation of a formal package: the parent 720 -- generic P1 which appears in the generic declaration, the fake 721 -- instantiation P2 which appears in the analyzed generic, and whose 722 -- visible entities may be used in subsequent formals, and the actual 723 -- P3 in the instance. To validate subsequent formals, me indicate 724 -- that the entities in P2 are mapped into those of P3. The mapping of 725 -- entities has to be done recursively for nested packages. 726 727 procedure Move_Freeze_Nodes 728 (Out_Of : Entity_Id; 729 After : Node_Id; 730 L : List_Id); 731 -- Freeze nodes can be generated in the analysis of a generic unit, but 732 -- will not be seen by the back-end. It is necessary to move those nodes 733 -- to the enclosing scope if they freeze an outer entity. We place them 734 -- at the end of the enclosing generic package, which is semantically 735 -- neutral. 736 737 procedure Preanalyze_Actuals (N : Node_Id); 738 -- Analyze actuals to perform name resolution. Full resolution is done 739 -- later, when the expected types are known, but names have to be captured 740 -- before installing parents of generics, that are not visible for the 741 -- actuals themselves. 742 743 function True_Parent (N : Node_Id) return Node_Id; 744 -- For a subunit, return parent of corresponding stub, else return 745 -- parent of node. 746 747 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 748 -- Verify that an attribute that appears as the default for a formal 749 -- subprogram is a function or procedure with the correct profile. 750 751 ------------------------------------------- 752 -- Data Structures for Generic Renamings -- 753 ------------------------------------------- 754 755 -- The map Generic_Renamings associates generic entities with their 756 -- corresponding actuals. Currently used to validate type instances. It 757 -- will eventually be used for all generic parameters to eliminate the 758 -- need for overload resolution in the instance. 759 760 type Assoc_Ptr is new Int; 761 762 Assoc_Null : constant Assoc_Ptr := -1; 763 764 type Assoc is record 765 Gen_Id : Entity_Id; 766 Act_Id : Entity_Id; 767 Next_In_HTable : Assoc_Ptr; 768 end record; 769 770 package Generic_Renamings is new Table.Table 771 (Table_Component_Type => Assoc, 772 Table_Index_Type => Assoc_Ptr, 773 Table_Low_Bound => 0, 774 Table_Initial => 10, 775 Table_Increment => 100, 776 Table_Name => "Generic_Renamings"); 777 778 -- Variable to hold enclosing instantiation. When the environment is 779 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 780 781 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 782 783 -- Hash table for associations 784 785 HTable_Size : constant := 37; 786 type HTable_Range is range 0 .. HTable_Size - 1; 787 788 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 789 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 790 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 791 function Hash (F : Entity_Id) return HTable_Range; 792 793 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 794 Header_Num => HTable_Range, 795 Element => Assoc, 796 Elmt_Ptr => Assoc_Ptr, 797 Null_Ptr => Assoc_Null, 798 Set_Next => Set_Next_Assoc, 799 Next => Next_Assoc, 800 Key => Entity_Id, 801 Get_Key => Get_Gen_Id, 802 Hash => Hash, 803 Equal => "="); 804 805 Exchanged_Views : Elist_Id; 806 -- This list holds the private views that have been exchanged during 807 -- instantiation to restore the visibility of the generic declaration. 808 -- (see comments above). After instantiation, the current visibility is 809 -- reestablished by means of a traversal of this list. 810 811 Hidden_Entities : Elist_Id; 812 -- This list holds the entities of the current scope that are removed 813 -- from immediate visibility when instantiating a child unit. Their 814 -- visibility is restored in Remove_Parent. 815 816 -- Because instantiations can be recursive, the following must be saved 817 -- on entry and restored on exit from an instantiation (spec or body). 818 -- This is done by the two procedures Save_Env and Restore_Env. For 819 -- package and subprogram instantiations (but not for the body instances) 820 -- the action of Save_Env is done in two steps: Init_Env is called before 821 -- Check_Generic_Child_Unit, because setting the parent instances requires 822 -- that the visibility data structures be properly initialized. Once the 823 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 824 825 Parent_Unit_Visible : Boolean := False; 826 -- Parent_Unit_Visible is used when the generic is a child unit, and 827 -- indicates whether the ultimate parent of the generic is visible in the 828 -- instantiation environment. It is used to reset the visibility of the 829 -- parent at the end of the instantiation (see Remove_Parent). 830 831 Instance_Parent_Unit : Entity_Id := Empty; 832 -- This records the ultimate parent unit of an instance of a generic 833 -- child unit and is used in conjunction with Parent_Unit_Visible to 834 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 835 836 type Instance_Env is record 837 Instantiated_Parent : Assoc; 838 Exchanged_Views : Elist_Id; 839 Hidden_Entities : Elist_Id; 840 Current_Sem_Unit : Unit_Number_Type; 841 Parent_Unit_Visible : Boolean := False; 842 Instance_Parent_Unit : Entity_Id := Empty; 843 Switches : Config_Switches_Type; 844 end record; 845 846 package Instance_Envs is new Table.Table ( 847 Table_Component_Type => Instance_Env, 848 Table_Index_Type => Int, 849 Table_Low_Bound => 0, 850 Table_Initial => 32, 851 Table_Increment => 100, 852 Table_Name => "Instance_Envs"); 853 854 procedure Restore_Private_Views 855 (Pack_Id : Entity_Id; 856 Is_Package : Boolean := True); 857 -- Restore the private views of external types, and unmark the generic 858 -- renamings of actuals, so that they become compatible subtypes again. 859 -- For subprograms, Pack_Id is the package constructed to hold the 860 -- renamings. 861 862 procedure Switch_View (T : Entity_Id); 863 -- Switch the partial and full views of a type and its private 864 -- dependents (i.e. its subtypes and derived types). 865 866 ------------------------------------ 867 -- Structures for Error Reporting -- 868 ------------------------------------ 869 870 Instantiation_Node : Node_Id; 871 -- Used by subprograms that validate instantiation of formal parameters 872 -- where there might be no actual on which to place the error message. 873 -- Also used to locate the instantiation node for generic subunits. 874 875 Instantiation_Error : exception; 876 -- When there is a semantic error in the generic parameter matching, 877 -- there is no point in continuing the instantiation, because the 878 -- number of cascaded errors is unpredictable. This exception aborts 879 -- the instantiation process altogether. 880 881 S_Adjustment : Sloc_Adjustment; 882 -- Offset created for each node in an instantiation, in order to keep 883 -- track of the source position of the instantiation in each of its nodes. 884 -- A subsequent semantic error or warning on a construct of the instance 885 -- points to both places: the original generic node, and the point of 886 -- instantiation. See Sinput and Sinput.L for additional details. 887 888 ------------------------------------------------------------ 889 -- Data structure for keeping track when inside a Generic -- 890 ------------------------------------------------------------ 891 892 -- The following table is used to save values of the Inside_A_Generic 893 -- flag (see spec of Sem) when they are saved by Start_Generic. 894 895 package Generic_Flags is new Table.Table ( 896 Table_Component_Type => Boolean, 897 Table_Index_Type => Int, 898 Table_Low_Bound => 0, 899 Table_Initial => 32, 900 Table_Increment => 200, 901 Table_Name => "Generic_Flags"); 902 903 --------------------------- 904 -- Abandon_Instantiation -- 905 --------------------------- 906 907 procedure Abandon_Instantiation (N : Node_Id) is 908 begin 909 Error_Msg_N ("\instantiation abandoned!", N); 910 raise Instantiation_Error; 911 end Abandon_Instantiation; 912 913 -------------------------- 914 -- Analyze_Associations -- 915 -------------------------- 916 917 function Analyze_Associations 918 (I_Node : Node_Id; 919 Formals : List_Id; 920 F_Copy : List_Id) return List_Id 921 is 922 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 923 Assoc : constant List_Id := New_List; 924 Default_Actuals : constant Elist_Id := New_Elmt_List; 925 Gen_Unit : constant Entity_Id := 926 Defining_Entity (Parent (F_Copy)); 927 928 Actuals : List_Id; 929 Actual : Node_Id; 930 Analyzed_Formal : Node_Id; 931 First_Named : Node_Id := Empty; 932 Formal : Node_Id; 933 Match : Node_Id; 934 Named : Node_Id; 935 Saved_Formal : Node_Id; 936 937 Default_Formals : constant List_Id := New_List; 938 -- If an Others_Choice is present, some of the formals may be defaulted. 939 -- To simplify the treatment of visibility in an instance, we introduce 940 -- individual defaults for each such formal. These defaults are 941 -- appended to the list of associations and replace the Others_Choice. 942 943 Found_Assoc : Node_Id; 944 -- Association for the current formal being match. Empty if there are 945 -- no remaining actuals, or if there is no named association with the 946 -- name of the formal. 947 948 Is_Named_Assoc : Boolean; 949 Num_Matched : Int := 0; 950 Num_Actuals : Int := 0; 951 952 Others_Present : Boolean := False; 953 Others_Choice : Node_Id := Empty; 954 -- In Ada 2005, indicates partial parameterization of a formal 955 -- package. As usual an other association must be last in the list. 956 957 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 958 -- Apply RM 12.3 (9): if a formal subprogram is overloaded, the instance 959 -- cannot have a named association for it. AI05-0025 extends this rule 960 -- to formals of formal packages by AI05-0025, and it also applies to 961 -- box-initialized formals. 962 963 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 964 -- Determine whether the parameter types and the return type of Subp 965 -- are fully defined at the point of instantiation. 966 967 function Matching_Actual 968 (F : Entity_Id; 969 A_F : Entity_Id) return Node_Id; 970 -- Find actual that corresponds to a given a formal parameter. If the 971 -- actuals are positional, return the next one, if any. If the actuals 972 -- are named, scan the parameter associations to find the right one. 973 -- A_F is the corresponding entity in the analyzed generic,which is 974 -- placed on the selector name for ASIS use. 975 -- 976 -- In Ada 2005, a named association may be given with a box, in which 977 -- case Matching_Actual sets Found_Assoc to the generic association, 978 -- but return Empty for the actual itself. In this case the code below 979 -- creates a corresponding declaration for the formal. 980 981 function Partial_Parameterization return Boolean; 982 -- Ada 2005: if no match is found for a given formal, check if the 983 -- association for it includes a box, or whether the associations 984 -- include an Others clause. 985 986 procedure Process_Default (F : Entity_Id); 987 -- Add a copy of the declaration of generic formal F to the list of 988 -- associations, and add an explicit box association for F if there 989 -- is none yet, and the default comes from an Others_Choice. 990 991 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 992 -- Determine whether Subp renames one of the subprograms defined in the 993 -- generated package Standard. 994 995 procedure Set_Analyzed_Formal; 996 -- Find the node in the generic copy that corresponds to a given formal. 997 -- The semantic information on this node is used to perform legality 998 -- checks on the actuals. Because semantic analysis can introduce some 999 -- anonymous entities or modify the declaration node itself, the 1000 -- correspondence between the two lists is not one-one. In addition to 1001 -- anonymous types, the presence a formal equality will introduce an 1002 -- implicit declaration for the corresponding inequality. 1003 1004 ---------------------------------------- 1005 -- Check_Overloaded_Formal_Subprogram -- 1006 ---------------------------------------- 1007 1008 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1009 Temp_Formal : Entity_Id; 1010 1011 begin 1012 Temp_Formal := First (Formals); 1013 while Present (Temp_Formal) loop 1014 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1015 and then Temp_Formal /= Formal 1016 and then 1017 Chars (Defining_Unit_Name (Specification (Formal))) = 1018 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1019 then 1020 if Present (Found_Assoc) then 1021 Error_Msg_N 1022 ("named association not allowed for overloaded formal", 1023 Found_Assoc); 1024 1025 else 1026 Error_Msg_N 1027 ("named association not allowed for overloaded formal", 1028 Others_Choice); 1029 end if; 1030 1031 Abandon_Instantiation (Instantiation_Node); 1032 end if; 1033 1034 Next (Temp_Formal); 1035 end loop; 1036 end Check_Overloaded_Formal_Subprogram; 1037 1038 ------------------------------- 1039 -- Has_Fully_Defined_Profile -- 1040 ------------------------------- 1041 1042 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1043 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1044 -- Determine whethet type Typ is fully defined 1045 1046 --------------------------- 1047 -- Is_Fully_Defined_Type -- 1048 --------------------------- 1049 1050 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1051 begin 1052 -- A private type without a full view is not fully defined 1053 1054 if Is_Private_Type (Typ) 1055 and then No (Full_View (Typ)) 1056 then 1057 return False; 1058 1059 -- An incomplete type is never fully defined 1060 1061 elsif Is_Incomplete_Type (Typ) then 1062 return False; 1063 1064 -- All other types are fully defined 1065 1066 else 1067 return True; 1068 end if; 1069 end Is_Fully_Defined_Type; 1070 1071 -- Local declarations 1072 1073 Param : Entity_Id; 1074 1075 -- Start of processing for Has_Fully_Defined_Profile 1076 1077 begin 1078 -- Check the parameters 1079 1080 Param := First_Formal (Subp); 1081 while Present (Param) loop 1082 if not Is_Fully_Defined_Type (Etype (Param)) then 1083 return False; 1084 end if; 1085 1086 Next_Formal (Param); 1087 end loop; 1088 1089 -- Check the return type 1090 1091 return Is_Fully_Defined_Type (Etype (Subp)); 1092 end Has_Fully_Defined_Profile; 1093 1094 --------------------- 1095 -- Matching_Actual -- 1096 --------------------- 1097 1098 function Matching_Actual 1099 (F : Entity_Id; 1100 A_F : Entity_Id) return Node_Id 1101 is 1102 Prev : Node_Id; 1103 Act : Node_Id; 1104 1105 begin 1106 Is_Named_Assoc := False; 1107 1108 -- End of list of purely positional parameters 1109 1110 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1111 Found_Assoc := Empty; 1112 Act := Empty; 1113 1114 -- Case of positional parameter corresponding to current formal 1115 1116 elsif No (Selector_Name (Actual)) then 1117 Found_Assoc := Actual; 1118 Act := Explicit_Generic_Actual_Parameter (Actual); 1119 Num_Matched := Num_Matched + 1; 1120 Next (Actual); 1121 1122 -- Otherwise scan list of named actuals to find the one with the 1123 -- desired name. All remaining actuals have explicit names. 1124 1125 else 1126 Is_Named_Assoc := True; 1127 Found_Assoc := Empty; 1128 Act := Empty; 1129 Prev := Empty; 1130 1131 while Present (Actual) loop 1132 if Chars (Selector_Name (Actual)) = Chars (F) then 1133 Set_Entity (Selector_Name (Actual), A_F); 1134 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1135 Generate_Reference (A_F, Selector_Name (Actual)); 1136 Found_Assoc := Actual; 1137 Act := Explicit_Generic_Actual_Parameter (Actual); 1138 Num_Matched := Num_Matched + 1; 1139 exit; 1140 end if; 1141 1142 Prev := Actual; 1143 Next (Actual); 1144 end loop; 1145 1146 -- Reset for subsequent searches. In most cases the named 1147 -- associations are in order. If they are not, we reorder them 1148 -- to avoid scanning twice the same actual. This is not just a 1149 -- question of efficiency: there may be multiple defaults with 1150 -- boxes that have the same name. In a nested instantiation we 1151 -- insert actuals for those defaults, and cannot rely on their 1152 -- names to disambiguate them. 1153 1154 if Actual = First_Named then 1155 Next (First_Named); 1156 1157 elsif Present (Actual) then 1158 Insert_Before (First_Named, Remove_Next (Prev)); 1159 end if; 1160 1161 Actual := First_Named; 1162 end if; 1163 1164 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1165 Set_Used_As_Generic_Actual (Entity (Act)); 1166 end if; 1167 1168 return Act; 1169 end Matching_Actual; 1170 1171 ------------------------------ 1172 -- Partial_Parameterization -- 1173 ------------------------------ 1174 1175 function Partial_Parameterization return Boolean is 1176 begin 1177 return Others_Present 1178 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1179 end Partial_Parameterization; 1180 1181 --------------------- 1182 -- Process_Default -- 1183 --------------------- 1184 1185 procedure Process_Default (F : Entity_Id) is 1186 Loc : constant Source_Ptr := Sloc (I_Node); 1187 F_Id : constant Entity_Id := Defining_Entity (F); 1188 Decl : Node_Id; 1189 Default : Node_Id; 1190 Id : Entity_Id; 1191 1192 begin 1193 -- Append copy of formal declaration to associations, and create new 1194 -- defining identifier for it. 1195 1196 Decl := New_Copy_Tree (F); 1197 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1198 1199 if Nkind (F) in N_Formal_Subprogram_Declaration then 1200 Set_Defining_Unit_Name (Specification (Decl), Id); 1201 1202 else 1203 Set_Defining_Identifier (Decl, Id); 1204 end if; 1205 1206 Append (Decl, Assoc); 1207 1208 if No (Found_Assoc) then 1209 Default := 1210 Make_Generic_Association (Loc, 1211 Selector_Name => New_Occurrence_Of (Id, Loc), 1212 Explicit_Generic_Actual_Parameter => Empty); 1213 Set_Box_Present (Default); 1214 Append (Default, Default_Formals); 1215 end if; 1216 end Process_Default; 1217 1218 --------------------------------- 1219 -- Renames_Standard_Subprogram -- 1220 --------------------------------- 1221 1222 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1223 Id : Entity_Id; 1224 1225 begin 1226 Id := Alias (Subp); 1227 while Present (Id) loop 1228 if Scope (Id) = Standard_Standard then 1229 return True; 1230 end if; 1231 1232 Id := Alias (Id); 1233 end loop; 1234 1235 return False; 1236 end Renames_Standard_Subprogram; 1237 1238 ------------------------- 1239 -- Set_Analyzed_Formal -- 1240 ------------------------- 1241 1242 procedure Set_Analyzed_Formal is 1243 Kind : Node_Kind; 1244 1245 begin 1246 while Present (Analyzed_Formal) loop 1247 Kind := Nkind (Analyzed_Formal); 1248 1249 case Nkind (Formal) is 1250 1251 when N_Formal_Subprogram_Declaration => 1252 exit when Kind in N_Formal_Subprogram_Declaration 1253 and then 1254 Chars 1255 (Defining_Unit_Name (Specification (Formal))) = 1256 Chars 1257 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1258 1259 when N_Formal_Package_Declaration => 1260 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1261 N_Generic_Package_Declaration, 1262 N_Package_Declaration); 1263 1264 when N_Use_Package_Clause | N_Use_Type_Clause => exit; 1265 1266 when others => 1267 1268 -- Skip freeze nodes, and nodes inserted to replace 1269 -- unrecognized pragmas. 1270 1271 exit when 1272 Kind not in N_Formal_Subprogram_Declaration 1273 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1274 N_Freeze_Entity, 1275 N_Null_Statement, 1276 N_Itype_Reference) 1277 and then Chars (Defining_Identifier (Formal)) = 1278 Chars (Defining_Identifier (Analyzed_Formal)); 1279 end case; 1280 1281 Next (Analyzed_Formal); 1282 end loop; 1283 end Set_Analyzed_Formal; 1284 1285 -- Start of processing for Analyze_Associations 1286 1287 begin 1288 Actuals := Generic_Associations (I_Node); 1289 1290 if Present (Actuals) then 1291 1292 -- Check for an Others choice, indicating a partial parameterization 1293 -- for a formal package. 1294 1295 Actual := First (Actuals); 1296 while Present (Actual) loop 1297 if Nkind (Actual) = N_Others_Choice then 1298 Others_Present := True; 1299 Others_Choice := Actual; 1300 1301 if Present (Next (Actual)) then 1302 Error_Msg_N ("others must be last association", Actual); 1303 end if; 1304 1305 -- This subprogram is used both for formal packages and for 1306 -- instantiations. For the latter, associations must all be 1307 -- explicit. 1308 1309 if Nkind (I_Node) /= N_Formal_Package_Declaration 1310 and then Comes_From_Source (I_Node) 1311 then 1312 Error_Msg_N 1313 ("others association not allowed in an instance", 1314 Actual); 1315 end if; 1316 1317 -- In any case, nothing to do after the others association 1318 1319 exit; 1320 1321 elsif Box_Present (Actual) 1322 and then Comes_From_Source (I_Node) 1323 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1324 then 1325 Error_Msg_N 1326 ("box association not allowed in an instance", Actual); 1327 end if; 1328 1329 Next (Actual); 1330 end loop; 1331 1332 -- If named associations are present, save first named association 1333 -- (it may of course be Empty) to facilitate subsequent name search. 1334 1335 First_Named := First (Actuals); 1336 while Present (First_Named) 1337 and then Nkind (First_Named) /= N_Others_Choice 1338 and then No (Selector_Name (First_Named)) 1339 loop 1340 Num_Actuals := Num_Actuals + 1; 1341 Next (First_Named); 1342 end loop; 1343 end if; 1344 1345 Named := First_Named; 1346 while Present (Named) loop 1347 if Nkind (Named) /= N_Others_Choice 1348 and then No (Selector_Name (Named)) 1349 then 1350 Error_Msg_N ("invalid positional actual after named one", Named); 1351 Abandon_Instantiation (Named); 1352 end if; 1353 1354 -- A named association may lack an actual parameter, if it was 1355 -- introduced for a default subprogram that turns out to be local 1356 -- to the outer instantiation. 1357 1358 if Nkind (Named) /= N_Others_Choice 1359 and then Present (Explicit_Generic_Actual_Parameter (Named)) 1360 then 1361 Num_Actuals := Num_Actuals + 1; 1362 end if; 1363 1364 Next (Named); 1365 end loop; 1366 1367 if Present (Formals) then 1368 Formal := First_Non_Pragma (Formals); 1369 Analyzed_Formal := First_Non_Pragma (F_Copy); 1370 1371 if Present (Actuals) then 1372 Actual := First (Actuals); 1373 1374 -- All formals should have default values 1375 1376 else 1377 Actual := Empty; 1378 end if; 1379 1380 while Present (Formal) loop 1381 Set_Analyzed_Formal; 1382 Saved_Formal := Next_Non_Pragma (Formal); 1383 1384 case Nkind (Formal) is 1385 when N_Formal_Object_Declaration => 1386 Match := 1387 Matching_Actual ( 1388 Defining_Identifier (Formal), 1389 Defining_Identifier (Analyzed_Formal)); 1390 1391 if No (Match) and then Partial_Parameterization then 1392 Process_Default (Formal); 1393 else 1394 Append_List 1395 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1396 Assoc); 1397 end if; 1398 1399 when N_Formal_Type_Declaration => 1400 Match := 1401 Matching_Actual ( 1402 Defining_Identifier (Formal), 1403 Defining_Identifier (Analyzed_Formal)); 1404 1405 if No (Match) then 1406 if Partial_Parameterization then 1407 Process_Default (Formal); 1408 1409 else 1410 Error_Msg_Sloc := Sloc (Gen_Unit); 1411 Error_Msg_NE 1412 ("missing actual&", 1413 Instantiation_Node, 1414 Defining_Identifier (Formal)); 1415 Error_Msg_NE ("\in instantiation of & declared#", 1416 Instantiation_Node, Gen_Unit); 1417 Abandon_Instantiation (Instantiation_Node); 1418 end if; 1419 1420 else 1421 Analyze (Match); 1422 Append_List 1423 (Instantiate_Type 1424 (Formal, Match, Analyzed_Formal, Assoc), 1425 Assoc); 1426 1427 -- An instantiation is a freeze point for the actuals, 1428 -- unless this is a rewritten formal package, or the 1429 -- formal is an Ada 2012 formal incomplete type. 1430 1431 if Nkind (I_Node) = N_Formal_Package_Declaration 1432 or else 1433 (Ada_Version >= Ada_2012 1434 and then 1435 Ekind (Defining_Identifier (Analyzed_Formal)) = 1436 E_Incomplete_Type) 1437 then 1438 null; 1439 1440 else 1441 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1442 end if; 1443 end if; 1444 1445 -- A remote access-to-class-wide type is not a legal actual 1446 -- for a generic formal of an access type (E.2.2(17/2)). 1447 -- In GNAT an exception to this rule is introduced when 1448 -- the formal is marked as remote using implementation 1449 -- defined aspect/pragma Remote_Access_Type. In that case 1450 -- the actual must be remote as well. 1451 1452 -- If the current instantiation is the construction of a 1453 -- local copy for a formal package the actuals may be 1454 -- defaulted, and there is no matching actual to check. 1455 1456 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1457 and then 1458 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1459 N_Access_To_Object_Definition 1460 and then Present (Match) 1461 then 1462 declare 1463 Formal_Ent : constant Entity_Id := 1464 Defining_Identifier (Analyzed_Formal); 1465 begin 1466 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1467 = Is_Remote_Types (Formal_Ent) 1468 then 1469 -- Remoteness of formal and actual match 1470 1471 null; 1472 1473 elsif Is_Remote_Types (Formal_Ent) then 1474 1475 -- Remote formal, non-remote actual 1476 1477 Error_Msg_NE 1478 ("actual for& must be remote", Match, Formal_Ent); 1479 1480 else 1481 -- Non-remote formal, remote actual 1482 1483 Error_Msg_NE 1484 ("actual for& may not be remote", 1485 Match, Formal_Ent); 1486 end if; 1487 end; 1488 end if; 1489 1490 when N_Formal_Subprogram_Declaration => 1491 Match := 1492 Matching_Actual 1493 (Defining_Unit_Name (Specification (Formal)), 1494 Defining_Unit_Name (Specification (Analyzed_Formal))); 1495 1496 -- If the formal subprogram has the same name as another 1497 -- formal subprogram of the generic, then a named 1498 -- association is illegal (12.3(9)). Exclude named 1499 -- associations that are generated for a nested instance. 1500 1501 if Present (Match) 1502 and then Is_Named_Assoc 1503 and then Comes_From_Source (Found_Assoc) 1504 then 1505 Check_Overloaded_Formal_Subprogram (Formal); 1506 end if; 1507 1508 -- If there is no corresponding actual, this may be case 1509 -- of partial parameterization, or else the formal has a 1510 -- default or a box. 1511 1512 if No (Match) and then Partial_Parameterization then 1513 Process_Default (Formal); 1514 1515 if Nkind (I_Node) = N_Formal_Package_Declaration then 1516 Check_Overloaded_Formal_Subprogram (Formal); 1517 end if; 1518 1519 else 1520 Append_To (Assoc, 1521 Instantiate_Formal_Subprogram 1522 (Formal, Match, Analyzed_Formal)); 1523 1524 -- An instantiation is a freeze point for the actuals, 1525 -- unless this is a rewritten formal package. 1526 1527 if Nkind (I_Node) /= N_Formal_Package_Declaration 1528 and then Nkind (Match) = N_Identifier 1529 and then Is_Subprogram (Entity (Match)) 1530 1531 -- The actual subprogram may rename a routine defined 1532 -- in Standard. Avoid freezing such renamings because 1533 -- subprograms coming from Standard cannot be frozen. 1534 1535 and then 1536 not Renames_Standard_Subprogram (Entity (Match)) 1537 1538 -- If the actual subprogram comes from a different 1539 -- unit, it is already frozen, either by a body in 1540 -- that unit or by the end of the declarative part 1541 -- of the unit. This check avoids the freezing of 1542 -- subprograms defined in Standard which are used 1543 -- as generic actuals. 1544 1545 and then In_Same_Code_Unit (Entity (Match), I_Node) 1546 and then Has_Fully_Defined_Profile (Entity (Match)) 1547 then 1548 -- Mark the subprogram as having a delayed freeze 1549 -- since this may be an out-of-order action. 1550 1551 Set_Has_Delayed_Freeze (Entity (Match)); 1552 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1553 end if; 1554 end if; 1555 1556 -- If this is a nested generic, preserve default for later 1557 -- instantiations. 1558 1559 if No (Match) 1560 and then Box_Present (Formal) 1561 then 1562 Append_Elmt 1563 (Defining_Unit_Name (Specification (Last (Assoc))), 1564 Default_Actuals); 1565 end if; 1566 1567 when N_Formal_Package_Declaration => 1568 Match := 1569 Matching_Actual ( 1570 Defining_Identifier (Formal), 1571 Defining_Identifier (Original_Node (Analyzed_Formal))); 1572 1573 if No (Match) then 1574 if Partial_Parameterization then 1575 Process_Default (Formal); 1576 1577 else 1578 Error_Msg_Sloc := Sloc (Gen_Unit); 1579 Error_Msg_NE 1580 ("missing actual&", 1581 Instantiation_Node, Defining_Identifier (Formal)); 1582 Error_Msg_NE ("\in instantiation of & declared#", 1583 Instantiation_Node, Gen_Unit); 1584 1585 Abandon_Instantiation (Instantiation_Node); 1586 end if; 1587 1588 else 1589 Analyze (Match); 1590 Append_List 1591 (Instantiate_Formal_Package 1592 (Formal, Match, Analyzed_Formal), 1593 Assoc); 1594 end if; 1595 1596 -- For use type and use package appearing in the generic part, 1597 -- we have already copied them, so we can just move them where 1598 -- they belong (we mustn't recopy them since this would mess up 1599 -- the Sloc values). 1600 1601 when N_Use_Package_Clause | 1602 N_Use_Type_Clause => 1603 if Nkind (Original_Node (I_Node)) = 1604 N_Formal_Package_Declaration 1605 then 1606 Append (New_Copy_Tree (Formal), Assoc); 1607 else 1608 Remove (Formal); 1609 Append (Formal, Assoc); 1610 end if; 1611 1612 when others => 1613 raise Program_Error; 1614 1615 end case; 1616 1617 Formal := Saved_Formal; 1618 Next_Non_Pragma (Analyzed_Formal); 1619 end loop; 1620 1621 if Num_Actuals > Num_Matched then 1622 Error_Msg_Sloc := Sloc (Gen_Unit); 1623 1624 if Present (Selector_Name (Actual)) then 1625 Error_Msg_NE 1626 ("unmatched actual&", 1627 Actual, Selector_Name (Actual)); 1628 Error_Msg_NE ("\in instantiation of& declared#", 1629 Actual, Gen_Unit); 1630 else 1631 Error_Msg_NE 1632 ("unmatched actual in instantiation of& declared#", 1633 Actual, Gen_Unit); 1634 end if; 1635 end if; 1636 1637 elsif Present (Actuals) then 1638 Error_Msg_N 1639 ("too many actuals in generic instantiation", Instantiation_Node); 1640 end if; 1641 1642 -- An instantiation freezes all generic actuals. The only exceptions 1643 -- to this are incomplete types and subprograms which are not fully 1644 -- defined at the point of instantiation. 1645 1646 declare 1647 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 1648 begin 1649 while Present (Elmt) loop 1650 Freeze_Before (I_Node, Node (Elmt)); 1651 Next_Elmt (Elmt); 1652 end loop; 1653 end; 1654 1655 -- If there are default subprograms, normalize the tree by adding 1656 -- explicit associations for them. This is required if the instance 1657 -- appears within a generic. 1658 1659 declare 1660 Elmt : Elmt_Id; 1661 Subp : Entity_Id; 1662 New_D : Node_Id; 1663 1664 begin 1665 Elmt := First_Elmt (Default_Actuals); 1666 while Present (Elmt) loop 1667 if No (Actuals) then 1668 Actuals := New_List; 1669 Set_Generic_Associations (I_Node, Actuals); 1670 end if; 1671 1672 Subp := Node (Elmt); 1673 New_D := 1674 Make_Generic_Association (Sloc (Subp), 1675 Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)), 1676 Explicit_Generic_Actual_Parameter => 1677 New_Occurrence_Of (Subp, Sloc (Subp))); 1678 Mark_Rewrite_Insertion (New_D); 1679 Append_To (Actuals, New_D); 1680 Next_Elmt (Elmt); 1681 end loop; 1682 end; 1683 1684 -- If this is a formal package, normalize the parameter list by adding 1685 -- explicit box associations for the formals that are covered by an 1686 -- Others_Choice. 1687 1688 if not Is_Empty_List (Default_Formals) then 1689 Append_List (Default_Formals, Formals); 1690 end if; 1691 1692 return Assoc; 1693 end Analyze_Associations; 1694 1695 ------------------------------- 1696 -- Analyze_Formal_Array_Type -- 1697 ------------------------------- 1698 1699 procedure Analyze_Formal_Array_Type 1700 (T : in out Entity_Id; 1701 Def : Node_Id) 1702 is 1703 DSS : Node_Id; 1704 1705 begin 1706 -- Treated like a non-generic array declaration, with additional 1707 -- semantic checks. 1708 1709 Enter_Name (T); 1710 1711 if Nkind (Def) = N_Constrained_Array_Definition then 1712 DSS := First (Discrete_Subtype_Definitions (Def)); 1713 while Present (DSS) loop 1714 if Nkind_In (DSS, N_Subtype_Indication, 1715 N_Range, 1716 N_Attribute_Reference) 1717 then 1718 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 1719 end if; 1720 1721 Next (DSS); 1722 end loop; 1723 end if; 1724 1725 Array_Type_Declaration (T, Def); 1726 Set_Is_Generic_Type (Base_Type (T)); 1727 1728 if Ekind (Component_Type (T)) = E_Incomplete_Type 1729 and then No (Full_View (Component_Type (T))) 1730 then 1731 Error_Msg_N ("premature usage of incomplete type", Def); 1732 1733 -- Check that range constraint is not allowed on the component type 1734 -- of a generic formal array type (AARM 12.5.3(3)) 1735 1736 elsif Is_Internal (Component_Type (T)) 1737 and then Present (Subtype_Indication (Component_Definition (Def))) 1738 and then Nkind (Original_Node 1739 (Subtype_Indication (Component_Definition (Def)))) = 1740 N_Subtype_Indication 1741 then 1742 Error_Msg_N 1743 ("in a formal, a subtype indication can only be " 1744 & "a subtype mark (RM 12.5.3(3))", 1745 Subtype_Indication (Component_Definition (Def))); 1746 end if; 1747 1748 end Analyze_Formal_Array_Type; 1749 1750 --------------------------------------------- 1751 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 1752 --------------------------------------------- 1753 1754 -- As for other generic types, we create a valid type representation with 1755 -- legal but arbitrary attributes, whose values are never considered 1756 -- static. For all scalar types we introduce an anonymous base type, with 1757 -- the same attributes. We choose the corresponding integer type to be 1758 -- Standard_Integer. 1759 -- Here and in other similar routines, the Sloc of the generated internal 1760 -- type must be the same as the sloc of the defining identifier of the 1761 -- formal type declaration, to provide proper source navigation. 1762 1763 procedure Analyze_Formal_Decimal_Fixed_Point_Type 1764 (T : Entity_Id; 1765 Def : Node_Id) 1766 is 1767 Loc : constant Source_Ptr := Sloc (Def); 1768 1769 Base : constant Entity_Id := 1770 New_Internal_Entity 1771 (E_Decimal_Fixed_Point_Type, 1772 Current_Scope, 1773 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1774 1775 Int_Base : constant Entity_Id := Standard_Integer; 1776 Delta_Val : constant Ureal := Ureal_1; 1777 Digs_Val : constant Uint := Uint_6; 1778 1779 begin 1780 Enter_Name (T); 1781 1782 Set_Etype (Base, Base); 1783 Set_Size_Info (Base, Int_Base); 1784 Set_RM_Size (Base, RM_Size (Int_Base)); 1785 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 1786 Set_Digits_Value (Base, Digs_Val); 1787 Set_Delta_Value (Base, Delta_Val); 1788 Set_Small_Value (Base, Delta_Val); 1789 Set_Scalar_Range (Base, 1790 Make_Range (Loc, 1791 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 1792 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 1793 1794 Set_Is_Generic_Type (Base); 1795 Set_Parent (Base, Parent (Def)); 1796 1797 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 1798 Set_Etype (T, Base); 1799 Set_Size_Info (T, Int_Base); 1800 Set_RM_Size (T, RM_Size (Int_Base)); 1801 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 1802 Set_Digits_Value (T, Digs_Val); 1803 Set_Delta_Value (T, Delta_Val); 1804 Set_Small_Value (T, Delta_Val); 1805 Set_Scalar_Range (T, Scalar_Range (Base)); 1806 Set_Is_Constrained (T); 1807 1808 Check_Restriction (No_Fixed_Point, Def); 1809 end Analyze_Formal_Decimal_Fixed_Point_Type; 1810 1811 ------------------------------------------- 1812 -- Analyze_Formal_Derived_Interface_Type -- 1813 ------------------------------------------- 1814 1815 procedure Analyze_Formal_Derived_Interface_Type 1816 (N : Node_Id; 1817 T : Entity_Id; 1818 Def : Node_Id) 1819 is 1820 Loc : constant Source_Ptr := Sloc (Def); 1821 1822 begin 1823 -- Rewrite as a type declaration of a derived type. This ensures that 1824 -- the interface list and primitive operations are properly captured. 1825 1826 Rewrite (N, 1827 Make_Full_Type_Declaration (Loc, 1828 Defining_Identifier => T, 1829 Type_Definition => Def)); 1830 Analyze (N); 1831 Set_Is_Generic_Type (T); 1832 end Analyze_Formal_Derived_Interface_Type; 1833 1834 --------------------------------- 1835 -- Analyze_Formal_Derived_Type -- 1836 --------------------------------- 1837 1838 procedure Analyze_Formal_Derived_Type 1839 (N : Node_Id; 1840 T : Entity_Id; 1841 Def : Node_Id) 1842 is 1843 Loc : constant Source_Ptr := Sloc (Def); 1844 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 1845 New_N : Node_Id; 1846 1847 begin 1848 Set_Is_Generic_Type (T); 1849 1850 if Private_Present (Def) then 1851 New_N := 1852 Make_Private_Extension_Declaration (Loc, 1853 Defining_Identifier => T, 1854 Discriminant_Specifications => Discriminant_Specifications (N), 1855 Unknown_Discriminants_Present => Unk_Disc, 1856 Subtype_Indication => Subtype_Mark (Def), 1857 Interface_List => Interface_List (Def)); 1858 1859 Set_Abstract_Present (New_N, Abstract_Present (Def)); 1860 Set_Limited_Present (New_N, Limited_Present (Def)); 1861 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 1862 1863 else 1864 New_N := 1865 Make_Full_Type_Declaration (Loc, 1866 Defining_Identifier => T, 1867 Discriminant_Specifications => 1868 Discriminant_Specifications (Parent (T)), 1869 Type_Definition => 1870 Make_Derived_Type_Definition (Loc, 1871 Subtype_Indication => Subtype_Mark (Def))); 1872 1873 Set_Abstract_Present 1874 (Type_Definition (New_N), Abstract_Present (Def)); 1875 Set_Limited_Present 1876 (Type_Definition (New_N), Limited_Present (Def)); 1877 end if; 1878 1879 Rewrite (N, New_N); 1880 Analyze (N); 1881 1882 if Unk_Disc then 1883 if not Is_Composite_Type (T) then 1884 Error_Msg_N 1885 ("unknown discriminants not allowed for elementary types", N); 1886 else 1887 Set_Has_Unknown_Discriminants (T); 1888 Set_Is_Constrained (T, False); 1889 end if; 1890 end if; 1891 1892 -- If the parent type has a known size, so does the formal, which makes 1893 -- legal representation clauses that involve the formal. 1894 1895 Set_Size_Known_At_Compile_Time 1896 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 1897 end Analyze_Formal_Derived_Type; 1898 1899 ---------------------------------- 1900 -- Analyze_Formal_Discrete_Type -- 1901 ---------------------------------- 1902 1903 -- The operations defined for a discrete types are those of an enumeration 1904 -- type. The size is set to an arbitrary value, for use in analyzing the 1905 -- generic unit. 1906 1907 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 1908 Loc : constant Source_Ptr := Sloc (Def); 1909 Lo : Node_Id; 1910 Hi : Node_Id; 1911 1912 Base : constant Entity_Id := 1913 New_Internal_Entity 1914 (E_Floating_Point_Type, Current_Scope, 1915 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1916 1917 begin 1918 Enter_Name (T); 1919 Set_Ekind (T, E_Enumeration_Subtype); 1920 Set_Etype (T, Base); 1921 Init_Size (T, 8); 1922 Init_Alignment (T); 1923 Set_Is_Generic_Type (T); 1924 Set_Is_Constrained (T); 1925 1926 -- For semantic analysis, the bounds of the type must be set to some 1927 -- non-static value. The simplest is to create attribute nodes for those 1928 -- bounds, that refer to the type itself. These bounds are never 1929 -- analyzed but serve as place-holders. 1930 1931 Lo := 1932 Make_Attribute_Reference (Loc, 1933 Attribute_Name => Name_First, 1934 Prefix => New_Occurrence_Of (T, Loc)); 1935 Set_Etype (Lo, T); 1936 1937 Hi := 1938 Make_Attribute_Reference (Loc, 1939 Attribute_Name => Name_Last, 1940 Prefix => New_Occurrence_Of (T, Loc)); 1941 Set_Etype (Hi, T); 1942 1943 Set_Scalar_Range (T, 1944 Make_Range (Loc, 1945 Low_Bound => Lo, 1946 High_Bound => Hi)); 1947 1948 Set_Ekind (Base, E_Enumeration_Type); 1949 Set_Etype (Base, Base); 1950 Init_Size (Base, 8); 1951 Init_Alignment (Base); 1952 Set_Is_Generic_Type (Base); 1953 Set_Scalar_Range (Base, Scalar_Range (T)); 1954 Set_Parent (Base, Parent (Def)); 1955 end Analyze_Formal_Discrete_Type; 1956 1957 ---------------------------------- 1958 -- Analyze_Formal_Floating_Type -- 1959 --------------------------------- 1960 1961 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 1962 Base : constant Entity_Id := 1963 New_Internal_Entity 1964 (E_Floating_Point_Type, Current_Scope, 1965 Sloc (Defining_Identifier (Parent (Def))), 'G'); 1966 1967 begin 1968 -- The various semantic attributes are taken from the predefined type 1969 -- Float, just so that all of them are initialized. Their values are 1970 -- never used because no constant folding or expansion takes place in 1971 -- the generic itself. 1972 1973 Enter_Name (T); 1974 Set_Ekind (T, E_Floating_Point_Subtype); 1975 Set_Etype (T, Base); 1976 Set_Size_Info (T, (Standard_Float)); 1977 Set_RM_Size (T, RM_Size (Standard_Float)); 1978 Set_Digits_Value (T, Digits_Value (Standard_Float)); 1979 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 1980 Set_Is_Constrained (T); 1981 1982 Set_Is_Generic_Type (Base); 1983 Set_Etype (Base, Base); 1984 Set_Size_Info (Base, (Standard_Float)); 1985 Set_RM_Size (Base, RM_Size (Standard_Float)); 1986 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 1987 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 1988 Set_Parent (Base, Parent (Def)); 1989 1990 Check_Restriction (No_Floating_Point, Def); 1991 end Analyze_Formal_Floating_Type; 1992 1993 ----------------------------------- 1994 -- Analyze_Formal_Interface_Type;-- 1995 ----------------------------------- 1996 1997 procedure Analyze_Formal_Interface_Type 1998 (N : Node_Id; 1999 T : Entity_Id; 2000 Def : Node_Id) 2001 is 2002 Loc : constant Source_Ptr := Sloc (N); 2003 New_N : Node_Id; 2004 2005 begin 2006 New_N := 2007 Make_Full_Type_Declaration (Loc, 2008 Defining_Identifier => T, 2009 Type_Definition => Def); 2010 2011 Rewrite (N, New_N); 2012 Analyze (N); 2013 Set_Is_Generic_Type (T); 2014 end Analyze_Formal_Interface_Type; 2015 2016 --------------------------------- 2017 -- Analyze_Formal_Modular_Type -- 2018 --------------------------------- 2019 2020 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2021 begin 2022 -- Apart from their entity kind, generic modular types are treated like 2023 -- signed integer types, and have the same attributes. 2024 2025 Analyze_Formal_Signed_Integer_Type (T, Def); 2026 Set_Ekind (T, E_Modular_Integer_Subtype); 2027 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2028 2029 end Analyze_Formal_Modular_Type; 2030 2031 --------------------------------------- 2032 -- Analyze_Formal_Object_Declaration -- 2033 --------------------------------------- 2034 2035 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2036 E : constant Node_Id := Default_Expression (N); 2037 Id : constant Node_Id := Defining_Identifier (N); 2038 K : Entity_Kind; 2039 T : Node_Id; 2040 2041 begin 2042 Enter_Name (Id); 2043 2044 -- Determine the mode of the formal object 2045 2046 if Out_Present (N) then 2047 K := E_Generic_In_Out_Parameter; 2048 2049 if not In_Present (N) then 2050 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2051 end if; 2052 2053 else 2054 K := E_Generic_In_Parameter; 2055 end if; 2056 2057 if Present (Subtype_Mark (N)) then 2058 Find_Type (Subtype_Mark (N)); 2059 T := Entity (Subtype_Mark (N)); 2060 2061 -- Verify that there is no redundant null exclusion 2062 2063 if Null_Exclusion_Present (N) then 2064 if not Is_Access_Type (T) then 2065 Error_Msg_N 2066 ("null exclusion can only apply to an access type", N); 2067 2068 elsif Can_Never_Be_Null (T) then 2069 Error_Msg_NE 2070 ("`NOT NULL` not allowed (& already excludes null)", 2071 N, T); 2072 end if; 2073 end if; 2074 2075 -- Ada 2005 (AI-423): Formal object with an access definition 2076 2077 else 2078 Check_Access_Definition (N); 2079 T := Access_Definition 2080 (Related_Nod => N, 2081 N => Access_Definition (N)); 2082 end if; 2083 2084 if Ekind (T) = E_Incomplete_Type then 2085 declare 2086 Error_Node : Node_Id; 2087 2088 begin 2089 if Present (Subtype_Mark (N)) then 2090 Error_Node := Subtype_Mark (N); 2091 else 2092 Check_Access_Definition (N); 2093 Error_Node := Access_Definition (N); 2094 end if; 2095 2096 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2097 end; 2098 end if; 2099 2100 if K = E_Generic_In_Parameter then 2101 2102 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2103 2104 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2105 Error_Msg_N 2106 ("generic formal of mode IN must not be of limited type", N); 2107 Explain_Limited_Type (T, N); 2108 end if; 2109 2110 if Is_Abstract_Type (T) then 2111 Error_Msg_N 2112 ("generic formal of mode IN must not be of abstract type", N); 2113 end if; 2114 2115 if Present (E) then 2116 Preanalyze_Spec_Expression (E, T); 2117 2118 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2119 Error_Msg_N 2120 ("initialization not allowed for limited types", E); 2121 Explain_Limited_Type (T, E); 2122 end if; 2123 end if; 2124 2125 Set_Ekind (Id, K); 2126 Set_Etype (Id, T); 2127 2128 -- Case of generic IN OUT parameter 2129 2130 else 2131 -- If the formal has an unconstrained type, construct its actual 2132 -- subtype, as is done for subprogram formals. In this fashion, all 2133 -- its uses can refer to specific bounds. 2134 2135 Set_Ekind (Id, K); 2136 Set_Etype (Id, T); 2137 2138 if (Is_Array_Type (T) 2139 and then not Is_Constrained (T)) 2140 or else 2141 (Ekind (T) = E_Record_Type 2142 and then Has_Discriminants (T)) 2143 then 2144 declare 2145 Non_Freezing_Ref : constant Node_Id := 2146 New_Occurrence_Of (Id, Sloc (Id)); 2147 Decl : Node_Id; 2148 2149 begin 2150 -- Make sure the actual subtype doesn't generate bogus freezing 2151 2152 Set_Must_Not_Freeze (Non_Freezing_Ref); 2153 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2154 Insert_Before_And_Analyze (N, Decl); 2155 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2156 end; 2157 else 2158 Set_Actual_Subtype (Id, T); 2159 end if; 2160 2161 if Present (E) then 2162 Error_Msg_N 2163 ("initialization not allowed for `IN OUT` formals", N); 2164 end if; 2165 end if; 2166 2167 if Has_Aspects (N) then 2168 Analyze_Aspect_Specifications (N, Id); 2169 end if; 2170 end Analyze_Formal_Object_Declaration; 2171 2172 ---------------------------------------------- 2173 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2174 ---------------------------------------------- 2175 2176 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2177 (T : Entity_Id; 2178 Def : Node_Id) 2179 is 2180 Loc : constant Source_Ptr := Sloc (Def); 2181 Base : constant Entity_Id := 2182 New_Internal_Entity 2183 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2184 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2185 2186 begin 2187 -- The semantic attributes are set for completeness only, their values 2188 -- will never be used, since all properties of the type are non-static. 2189 2190 Enter_Name (T); 2191 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2192 Set_Etype (T, Base); 2193 Set_Size_Info (T, Standard_Integer); 2194 Set_RM_Size (T, RM_Size (Standard_Integer)); 2195 Set_Small_Value (T, Ureal_1); 2196 Set_Delta_Value (T, Ureal_1); 2197 Set_Scalar_Range (T, 2198 Make_Range (Loc, 2199 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2200 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2201 Set_Is_Constrained (T); 2202 2203 Set_Is_Generic_Type (Base); 2204 Set_Etype (Base, Base); 2205 Set_Size_Info (Base, Standard_Integer); 2206 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2207 Set_Small_Value (Base, Ureal_1); 2208 Set_Delta_Value (Base, Ureal_1); 2209 Set_Scalar_Range (Base, Scalar_Range (T)); 2210 Set_Parent (Base, Parent (Def)); 2211 2212 Check_Restriction (No_Fixed_Point, Def); 2213 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2214 2215 ---------------------------------------- 2216 -- Analyze_Formal_Package_Declaration -- 2217 ---------------------------------------- 2218 2219 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2220 Loc : constant Source_Ptr := Sloc (N); 2221 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2222 Formal : Entity_Id; 2223 Gen_Id : constant Node_Id := Name (N); 2224 Gen_Decl : Node_Id; 2225 Gen_Unit : Entity_Id; 2226 New_N : Node_Id; 2227 Parent_Installed : Boolean := False; 2228 Renaming : Node_Id; 2229 Parent_Instance : Entity_Id; 2230 Renaming_In_Par : Entity_Id; 2231 Associations : Boolean := True; 2232 2233 Vis_Prims_List : Elist_Id := No_Elist; 2234 -- List of primitives made temporarily visible in the instantiation 2235 -- to match the visibility of the formal type 2236 2237 function Build_Local_Package return Node_Id; 2238 -- The formal package is rewritten so that its parameters are replaced 2239 -- with corresponding declarations. For parameters with bona fide 2240 -- associations these declarations are created by Analyze_Associations 2241 -- as for a regular instantiation. For boxed parameters, we preserve 2242 -- the formal declarations and analyze them, in order to introduce 2243 -- entities of the right kind in the environment of the formal. 2244 2245 ------------------------- 2246 -- Build_Local_Package -- 2247 ------------------------- 2248 2249 function Build_Local_Package return Node_Id is 2250 Decls : List_Id; 2251 Pack_Decl : Node_Id; 2252 2253 begin 2254 -- Within the formal, the name of the generic package is a renaming 2255 -- of the formal (as for a regular instantiation). 2256 2257 Pack_Decl := 2258 Make_Package_Declaration (Loc, 2259 Specification => 2260 Copy_Generic_Node 2261 (Specification (Original_Node (Gen_Decl)), 2262 Empty, Instantiating => True)); 2263 2264 Renaming := Make_Package_Renaming_Declaration (Loc, 2265 Defining_Unit_Name => 2266 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2267 Name => New_Occurrence_Of (Formal, Loc)); 2268 2269 if Nkind (Gen_Id) = N_Identifier 2270 and then Chars (Gen_Id) = Chars (Pack_Id) 2271 then 2272 Error_Msg_NE 2273 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2274 end if; 2275 2276 -- If the formal is declared with a box, or with an others choice, 2277 -- create corresponding declarations for all entities in the formal 2278 -- part, so that names with the proper types are available in the 2279 -- specification of the formal package. 2280 2281 -- On the other hand, if there are no associations, then all the 2282 -- formals must have defaults, and this will be checked by the 2283 -- call to Analyze_Associations. 2284 2285 if Box_Present (N) 2286 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2287 then 2288 declare 2289 Formal_Decl : Node_Id; 2290 2291 begin 2292 -- TBA : for a formal package, need to recurse ??? 2293 2294 Decls := New_List; 2295 Formal_Decl := 2296 First 2297 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2298 while Present (Formal_Decl) loop 2299 Append_To 2300 (Decls, Copy_Generic_Node (Formal_Decl, Empty, True)); 2301 Next (Formal_Decl); 2302 end loop; 2303 end; 2304 2305 -- If generic associations are present, use Analyze_Associations to 2306 -- create the proper renaming declarations. 2307 2308 else 2309 declare 2310 Act_Tree : constant Node_Id := 2311 Copy_Generic_Node 2312 (Original_Node (Gen_Decl), Empty, 2313 Instantiating => True); 2314 2315 begin 2316 Generic_Renamings.Set_Last (0); 2317 Generic_Renamings_HTable.Reset; 2318 Instantiation_Node := N; 2319 2320 Decls := 2321 Analyze_Associations 2322 (I_Node => Original_Node (N), 2323 Formals => Generic_Formal_Declarations (Act_Tree), 2324 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2325 2326 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2327 end; 2328 end if; 2329 2330 Append (Renaming, To => Decls); 2331 2332 -- Add generated declarations ahead of local declarations in 2333 -- the package. 2334 2335 if No (Visible_Declarations (Specification (Pack_Decl))) then 2336 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2337 else 2338 Insert_List_Before 2339 (First (Visible_Declarations (Specification (Pack_Decl))), 2340 Decls); 2341 end if; 2342 2343 return Pack_Decl; 2344 end Build_Local_Package; 2345 2346 -- Start of processing for Analyze_Formal_Package_Declaration 2347 2348 begin 2349 Text_IO_Kludge (Gen_Id); 2350 2351 Init_Env; 2352 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2353 Gen_Unit := Entity (Gen_Id); 2354 2355 -- Check for a formal package that is a package renaming 2356 2357 if Present (Renamed_Object (Gen_Unit)) then 2358 2359 -- Indicate that unit is used, before replacing it with renamed 2360 -- entity for use below. 2361 2362 if In_Extended_Main_Source_Unit (N) then 2363 Set_Is_Instantiated (Gen_Unit); 2364 Generate_Reference (Gen_Unit, N); 2365 end if; 2366 2367 Gen_Unit := Renamed_Object (Gen_Unit); 2368 end if; 2369 2370 if Ekind (Gen_Unit) /= E_Generic_Package then 2371 Error_Msg_N ("expect generic package name", Gen_Id); 2372 Restore_Env; 2373 goto Leave; 2374 2375 elsif Gen_Unit = Current_Scope then 2376 Error_Msg_N 2377 ("generic package cannot be used as a formal package of itself", 2378 Gen_Id); 2379 Restore_Env; 2380 goto Leave; 2381 2382 elsif In_Open_Scopes (Gen_Unit) then 2383 if Is_Compilation_Unit (Gen_Unit) 2384 and then Is_Child_Unit (Current_Scope) 2385 then 2386 -- Special-case the error when the formal is a parent, and 2387 -- continue analysis to minimize cascaded errors. 2388 2389 Error_Msg_N 2390 ("generic parent cannot be used as formal package " 2391 & "of a child unit", 2392 Gen_Id); 2393 2394 else 2395 Error_Msg_N 2396 ("generic package cannot be used as a formal package " 2397 & "within itself", 2398 Gen_Id); 2399 Restore_Env; 2400 goto Leave; 2401 end if; 2402 end if; 2403 2404 -- Check that name of formal package does not hide name of generic, 2405 -- or its leading prefix. This check must be done separately because 2406 -- the name of the generic has already been analyzed. 2407 2408 declare 2409 Gen_Name : Entity_Id; 2410 2411 begin 2412 Gen_Name := Gen_Id; 2413 while Nkind (Gen_Name) = N_Expanded_Name loop 2414 Gen_Name := Prefix (Gen_Name); 2415 end loop; 2416 2417 if Chars (Gen_Name) = Chars (Pack_Id) then 2418 Error_Msg_NE 2419 ("& is hidden within declaration of formal package", 2420 Gen_Id, Gen_Name); 2421 end if; 2422 end; 2423 2424 if Box_Present (N) 2425 or else No (Generic_Associations (N)) 2426 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2427 then 2428 Associations := False; 2429 end if; 2430 2431 -- If there are no generic associations, the generic parameters appear 2432 -- as local entities and are instantiated like them. We copy the generic 2433 -- package declaration as if it were an instantiation, and analyze it 2434 -- like a regular package, except that we treat the formals as 2435 -- additional visible components. 2436 2437 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2438 2439 if In_Extended_Main_Source_Unit (N) then 2440 Set_Is_Instantiated (Gen_Unit); 2441 Generate_Reference (Gen_Unit, N); 2442 end if; 2443 2444 Formal := New_Copy (Pack_Id); 2445 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 2446 2447 begin 2448 -- Make local generic without formals. The formals will be replaced 2449 -- with internal declarations. 2450 2451 New_N := Build_Local_Package; 2452 2453 -- If there are errors in the parameter list, Analyze_Associations 2454 -- raises Instantiation_Error. Patch the declaration to prevent 2455 -- further exception propagation. 2456 2457 exception 2458 when Instantiation_Error => 2459 2460 Enter_Name (Formal); 2461 Set_Ekind (Formal, E_Variable); 2462 Set_Etype (Formal, Any_Type); 2463 Restore_Hidden_Primitives (Vis_Prims_List); 2464 2465 if Parent_Installed then 2466 Remove_Parent; 2467 end if; 2468 2469 goto Leave; 2470 end; 2471 2472 Rewrite (N, New_N); 2473 Set_Defining_Unit_Name (Specification (New_N), Formal); 2474 Set_Generic_Parent (Specification (N), Gen_Unit); 2475 Set_Instance_Env (Gen_Unit, Formal); 2476 Set_Is_Generic_Instance (Formal); 2477 2478 Enter_Name (Formal); 2479 Set_Ekind (Formal, E_Package); 2480 Set_Etype (Formal, Standard_Void_Type); 2481 Set_Inner_Instances (Formal, New_Elmt_List); 2482 Push_Scope (Formal); 2483 2484 if Is_Child_Unit (Gen_Unit) 2485 and then Parent_Installed 2486 then 2487 -- Similarly, we have to make the name of the formal visible in the 2488 -- parent instance, to resolve properly fully qualified names that 2489 -- may appear in the generic unit. The parent instance has been 2490 -- placed on the scope stack ahead of the current scope. 2491 2492 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2493 2494 Renaming_In_Par := 2495 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2496 Set_Ekind (Renaming_In_Par, E_Package); 2497 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2498 Set_Scope (Renaming_In_Par, Parent_Instance); 2499 Set_Parent (Renaming_In_Par, Parent (Formal)); 2500 Set_Renamed_Object (Renaming_In_Par, Formal); 2501 Append_Entity (Renaming_In_Par, Parent_Instance); 2502 end if; 2503 2504 Analyze (Specification (N)); 2505 2506 -- The formals for which associations are provided are not visible 2507 -- outside of the formal package. The others are still declared by a 2508 -- formal parameter declaration. 2509 2510 -- If there are no associations, the only local entity to hide is the 2511 -- generated package renaming itself. 2512 2513 declare 2514 E : Entity_Id; 2515 2516 begin 2517 E := First_Entity (Formal); 2518 while Present (E) loop 2519 if Associations 2520 and then not Is_Generic_Formal (E) 2521 then 2522 Set_Is_Hidden (E); 2523 end if; 2524 2525 if Ekind (E) = E_Package 2526 and then Renamed_Entity (E) = Formal 2527 then 2528 Set_Is_Hidden (E); 2529 exit; 2530 end if; 2531 2532 Next_Entity (E); 2533 end loop; 2534 end; 2535 2536 End_Package_Scope (Formal); 2537 Restore_Hidden_Primitives (Vis_Prims_List); 2538 2539 if Parent_Installed then 2540 Remove_Parent; 2541 end if; 2542 2543 Restore_Env; 2544 2545 -- Inside the generic unit, the formal package is a regular package, but 2546 -- no body is needed for it. Note that after instantiation, the defining 2547 -- unit name we need is in the new tree and not in the original (see 2548 -- Package_Instantiation). A generic formal package is an instance, and 2549 -- can be used as an actual for an inner instance. 2550 2551 Set_Has_Completion (Formal, True); 2552 2553 -- Add semantic information to the original defining identifier. 2554 -- for ASIS use. 2555 2556 Set_Ekind (Pack_Id, E_Package); 2557 Set_Etype (Pack_Id, Standard_Void_Type); 2558 Set_Scope (Pack_Id, Scope (Formal)); 2559 Set_Has_Completion (Pack_Id, True); 2560 2561 <<Leave>> 2562 if Has_Aspects (N) then 2563 Analyze_Aspect_Specifications (N, Pack_Id); 2564 end if; 2565 end Analyze_Formal_Package_Declaration; 2566 2567 --------------------------------- 2568 -- Analyze_Formal_Private_Type -- 2569 --------------------------------- 2570 2571 procedure Analyze_Formal_Private_Type 2572 (N : Node_Id; 2573 T : Entity_Id; 2574 Def : Node_Id) 2575 is 2576 begin 2577 New_Private_Type (N, T, Def); 2578 2579 -- Set the size to an arbitrary but legal value 2580 2581 Set_Size_Info (T, Standard_Integer); 2582 Set_RM_Size (T, RM_Size (Standard_Integer)); 2583 end Analyze_Formal_Private_Type; 2584 2585 ------------------------------------ 2586 -- Analyze_Formal_Incomplete_Type -- 2587 ------------------------------------ 2588 2589 procedure Analyze_Formal_Incomplete_Type 2590 (T : Entity_Id; 2591 Def : Node_Id) 2592 is 2593 begin 2594 Enter_Name (T); 2595 Set_Ekind (T, E_Incomplete_Type); 2596 Set_Etype (T, T); 2597 Set_Private_Dependents (T, New_Elmt_List); 2598 2599 if Tagged_Present (Def) then 2600 Set_Is_Tagged_Type (T); 2601 Make_Class_Wide_Type (T); 2602 Set_Direct_Primitive_Operations (T, New_Elmt_List); 2603 end if; 2604 end Analyze_Formal_Incomplete_Type; 2605 2606 ---------------------------------------- 2607 -- Analyze_Formal_Signed_Integer_Type -- 2608 ---------------------------------------- 2609 2610 procedure Analyze_Formal_Signed_Integer_Type 2611 (T : Entity_Id; 2612 Def : Node_Id) 2613 is 2614 Base : constant Entity_Id := 2615 New_Internal_Entity 2616 (E_Signed_Integer_Type, 2617 Current_Scope, 2618 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2619 2620 begin 2621 Enter_Name (T); 2622 2623 Set_Ekind (T, E_Signed_Integer_Subtype); 2624 Set_Etype (T, Base); 2625 Set_Size_Info (T, Standard_Integer); 2626 Set_RM_Size (T, RM_Size (Standard_Integer)); 2627 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 2628 Set_Is_Constrained (T); 2629 2630 Set_Is_Generic_Type (Base); 2631 Set_Size_Info (Base, Standard_Integer); 2632 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2633 Set_Etype (Base, Base); 2634 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 2635 Set_Parent (Base, Parent (Def)); 2636 end Analyze_Formal_Signed_Integer_Type; 2637 2638 ------------------------------------------- 2639 -- Analyze_Formal_Subprogram_Declaration -- 2640 ------------------------------------------- 2641 2642 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 2643 Spec : constant Node_Id := Specification (N); 2644 Def : constant Node_Id := Default_Name (N); 2645 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 2646 Subp : Entity_Id; 2647 2648 begin 2649 if Nam = Error then 2650 return; 2651 end if; 2652 2653 if Nkind (Nam) = N_Defining_Program_Unit_Name then 2654 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 2655 goto Leave; 2656 end if; 2657 2658 Analyze_Subprogram_Declaration (N); 2659 Set_Is_Formal_Subprogram (Nam); 2660 Set_Has_Completion (Nam); 2661 2662 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 2663 Set_Is_Abstract_Subprogram (Nam); 2664 Set_Is_Dispatching_Operation (Nam); 2665 2666 declare 2667 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 2668 begin 2669 if No (Ctrl_Type) then 2670 Error_Msg_N 2671 ("abstract formal subprogram must have a controlling type", 2672 N); 2673 2674 elsif Ada_Version >= Ada_2012 2675 and then Is_Incomplete_Type (Ctrl_Type) 2676 then 2677 Error_Msg_NE 2678 ("controlling type of abstract formal subprogram cannot " & 2679 "be incomplete type", N, Ctrl_Type); 2680 2681 else 2682 Check_Controlling_Formals (Ctrl_Type, Nam); 2683 end if; 2684 end; 2685 end if; 2686 2687 -- Default name is resolved at the point of instantiation 2688 2689 if Box_Present (N) then 2690 null; 2691 2692 -- Else default is bound at the point of generic declaration 2693 2694 elsif Present (Def) then 2695 if Nkind (Def) = N_Operator_Symbol then 2696 Find_Direct_Name (Def); 2697 2698 elsif Nkind (Def) /= N_Attribute_Reference then 2699 Analyze (Def); 2700 2701 else 2702 -- For an attribute reference, analyze the prefix and verify 2703 -- that it has the proper profile for the subprogram. 2704 2705 Analyze (Prefix (Def)); 2706 Valid_Default_Attribute (Nam, Def); 2707 goto Leave; 2708 end if; 2709 2710 -- Default name may be overloaded, in which case the interpretation 2711 -- with the correct profile must be selected, as for a renaming. 2712 -- If the definition is an indexed component, it must denote a 2713 -- member of an entry family. If it is a selected component, it 2714 -- can be a protected operation. 2715 2716 if Etype (Def) = Any_Type then 2717 goto Leave; 2718 2719 elsif Nkind (Def) = N_Selected_Component then 2720 if not Is_Overloadable (Entity (Selector_Name (Def))) then 2721 Error_Msg_N ("expect valid subprogram name as default", Def); 2722 end if; 2723 2724 elsif Nkind (Def) = N_Indexed_Component then 2725 if Is_Entity_Name (Prefix (Def)) then 2726 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 2727 Error_Msg_N ("expect valid subprogram name as default", Def); 2728 end if; 2729 2730 elsif Nkind (Prefix (Def)) = N_Selected_Component then 2731 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 2732 E_Entry_Family 2733 then 2734 Error_Msg_N ("expect valid subprogram name as default", Def); 2735 end if; 2736 2737 else 2738 Error_Msg_N ("expect valid subprogram name as default", Def); 2739 goto Leave; 2740 end if; 2741 2742 elsif Nkind (Def) = N_Character_Literal then 2743 2744 -- Needs some type checks: subprogram should be parameterless??? 2745 2746 Resolve (Def, (Etype (Nam))); 2747 2748 elsif not Is_Entity_Name (Def) 2749 or else not Is_Overloadable (Entity (Def)) 2750 then 2751 Error_Msg_N ("expect valid subprogram name as default", Def); 2752 goto Leave; 2753 2754 elsif not Is_Overloaded (Def) then 2755 Subp := Entity (Def); 2756 2757 if Subp = Nam then 2758 Error_Msg_N ("premature usage of formal subprogram", Def); 2759 2760 elsif not Entity_Matches_Spec (Subp, Nam) then 2761 Error_Msg_N ("no visible entity matches specification", Def); 2762 end if; 2763 2764 -- More than one interpretation, so disambiguate as for a renaming 2765 2766 else 2767 declare 2768 I : Interp_Index; 2769 I1 : Interp_Index := 0; 2770 It : Interp; 2771 It1 : Interp; 2772 2773 begin 2774 Subp := Any_Id; 2775 Get_First_Interp (Def, I, It); 2776 while Present (It.Nam) loop 2777 if Entity_Matches_Spec (It.Nam, Nam) then 2778 if Subp /= Any_Id then 2779 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 2780 2781 if It1 = No_Interp then 2782 Error_Msg_N ("ambiguous default subprogram", Def); 2783 else 2784 Subp := It1.Nam; 2785 end if; 2786 2787 exit; 2788 2789 else 2790 I1 := I; 2791 Subp := It.Nam; 2792 end if; 2793 end if; 2794 2795 Get_Next_Interp (I, It); 2796 end loop; 2797 end; 2798 2799 if Subp /= Any_Id then 2800 2801 -- Subprogram found, generate reference to it 2802 2803 Set_Entity (Def, Subp); 2804 Generate_Reference (Subp, Def); 2805 2806 if Subp = Nam then 2807 Error_Msg_N ("premature usage of formal subprogram", Def); 2808 2809 elsif Ekind (Subp) /= E_Operator then 2810 Check_Mode_Conformant (Subp, Nam); 2811 end if; 2812 2813 else 2814 Error_Msg_N ("no visible subprogram matches specification", N); 2815 end if; 2816 end if; 2817 end if; 2818 2819 <<Leave>> 2820 if Has_Aspects (N) then 2821 Analyze_Aspect_Specifications (N, Nam); 2822 end if; 2823 2824 end Analyze_Formal_Subprogram_Declaration; 2825 2826 ------------------------------------- 2827 -- Analyze_Formal_Type_Declaration -- 2828 ------------------------------------- 2829 2830 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 2831 Def : constant Node_Id := Formal_Type_Definition (N); 2832 T : Entity_Id; 2833 2834 begin 2835 T := Defining_Identifier (N); 2836 2837 if Present (Discriminant_Specifications (N)) 2838 and then Nkind (Def) /= N_Formal_Private_Type_Definition 2839 then 2840 Error_Msg_N 2841 ("discriminants not allowed for this formal type", T); 2842 end if; 2843 2844 -- Enter the new name, and branch to specific routine 2845 2846 case Nkind (Def) is 2847 when N_Formal_Private_Type_Definition => 2848 Analyze_Formal_Private_Type (N, T, Def); 2849 2850 when N_Formal_Derived_Type_Definition => 2851 Analyze_Formal_Derived_Type (N, T, Def); 2852 2853 when N_Formal_Incomplete_Type_Definition => 2854 Analyze_Formal_Incomplete_Type (T, Def); 2855 2856 when N_Formal_Discrete_Type_Definition => 2857 Analyze_Formal_Discrete_Type (T, Def); 2858 2859 when N_Formal_Signed_Integer_Type_Definition => 2860 Analyze_Formal_Signed_Integer_Type (T, Def); 2861 2862 when N_Formal_Modular_Type_Definition => 2863 Analyze_Formal_Modular_Type (T, Def); 2864 2865 when N_Formal_Floating_Point_Definition => 2866 Analyze_Formal_Floating_Type (T, Def); 2867 2868 when N_Formal_Ordinary_Fixed_Point_Definition => 2869 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 2870 2871 when N_Formal_Decimal_Fixed_Point_Definition => 2872 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 2873 2874 when N_Array_Type_Definition => 2875 Analyze_Formal_Array_Type (T, Def); 2876 2877 when N_Access_To_Object_Definition | 2878 N_Access_Function_Definition | 2879 N_Access_Procedure_Definition => 2880 Analyze_Generic_Access_Type (T, Def); 2881 2882 -- Ada 2005: a interface declaration is encoded as an abstract 2883 -- record declaration or a abstract type derivation. 2884 2885 when N_Record_Definition => 2886 Analyze_Formal_Interface_Type (N, T, Def); 2887 2888 when N_Derived_Type_Definition => 2889 Analyze_Formal_Derived_Interface_Type (N, T, Def); 2890 2891 when N_Error => 2892 null; 2893 2894 when others => 2895 raise Program_Error; 2896 2897 end case; 2898 2899 Set_Is_Generic_Type (T); 2900 2901 if Has_Aspects (N) then 2902 Analyze_Aspect_Specifications (N, T); 2903 end if; 2904 end Analyze_Formal_Type_Declaration; 2905 2906 ------------------------------------ 2907 -- Analyze_Function_Instantiation -- 2908 ------------------------------------ 2909 2910 procedure Analyze_Function_Instantiation (N : Node_Id) is 2911 begin 2912 Analyze_Subprogram_Instantiation (N, E_Function); 2913 end Analyze_Function_Instantiation; 2914 2915 --------------------------------- 2916 -- Analyze_Generic_Access_Type -- 2917 --------------------------------- 2918 2919 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 2920 begin 2921 Enter_Name (T); 2922 2923 if Nkind (Def) = N_Access_To_Object_Definition then 2924 Access_Type_Declaration (T, Def); 2925 2926 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 2927 and then No (Full_View (Designated_Type (T))) 2928 and then not Is_Generic_Type (Designated_Type (T)) 2929 then 2930 Error_Msg_N ("premature usage of incomplete type", Def); 2931 2932 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 2933 Error_Msg_N 2934 ("only a subtype mark is allowed in a formal", Def); 2935 end if; 2936 2937 else 2938 Access_Subprogram_Declaration (T, Def); 2939 end if; 2940 end Analyze_Generic_Access_Type; 2941 2942 --------------------------------- 2943 -- Analyze_Generic_Formal_Part -- 2944 --------------------------------- 2945 2946 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 2947 Gen_Parm_Decl : Node_Id; 2948 2949 begin 2950 -- The generic formals are processed in the scope of the generic unit, 2951 -- where they are immediately visible. The scope is installed by the 2952 -- caller. 2953 2954 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 2955 2956 while Present (Gen_Parm_Decl) loop 2957 Analyze (Gen_Parm_Decl); 2958 Next (Gen_Parm_Decl); 2959 end loop; 2960 2961 Generate_Reference_To_Generic_Formals (Current_Scope); 2962 end Analyze_Generic_Formal_Part; 2963 2964 ------------------------------------------ 2965 -- Analyze_Generic_Package_Declaration -- 2966 ------------------------------------------ 2967 2968 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 2969 Loc : constant Source_Ptr := Sloc (N); 2970 Id : Entity_Id; 2971 New_N : Node_Id; 2972 Save_Parent : Node_Id; 2973 Renaming : Node_Id; 2974 Decls : constant List_Id := 2975 Visible_Declarations (Specification (N)); 2976 Decl : Node_Id; 2977 2978 begin 2979 Check_SPARK_Restriction ("generic is not allowed", N); 2980 2981 -- We introduce a renaming of the enclosing package, to have a usable 2982 -- entity as the prefix of an expanded name for a local entity of the 2983 -- form Par.P.Q, where P is the generic package. This is because a local 2984 -- entity named P may hide it, so that the usual visibility rules in 2985 -- the instance will not resolve properly. 2986 2987 Renaming := 2988 Make_Package_Renaming_Declaration (Loc, 2989 Defining_Unit_Name => 2990 Make_Defining_Identifier (Loc, 2991 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 2992 Name => Make_Identifier (Loc, Chars (Defining_Entity (N)))); 2993 2994 if Present (Decls) then 2995 Decl := First (Decls); 2996 while Present (Decl) 2997 and then Nkind (Decl) = N_Pragma 2998 loop 2999 Next (Decl); 3000 end loop; 3001 3002 if Present (Decl) then 3003 Insert_Before (Decl, Renaming); 3004 else 3005 Append (Renaming, Visible_Declarations (Specification (N))); 3006 end if; 3007 3008 else 3009 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3010 end if; 3011 3012 -- Create copy of generic unit, and save for instantiation. If the unit 3013 -- is a child unit, do not copy the specifications for the parent, which 3014 -- are not part of the generic tree. 3015 3016 Save_Parent := Parent_Spec (N); 3017 Set_Parent_Spec (N, Empty); 3018 3019 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3020 Set_Parent_Spec (New_N, Save_Parent); 3021 Rewrite (N, New_N); 3022 3023 -- Once the contents of the generic copy and the template are swapped, 3024 -- do the same for their respective aspect specifications. 3025 3026 Exchange_Aspects (N, New_N); 3027 Id := Defining_Entity (N); 3028 Generate_Definition (Id); 3029 3030 -- Expansion is not applied to generic units 3031 3032 Start_Generic; 3033 3034 Enter_Name (Id); 3035 Set_Ekind (Id, E_Generic_Package); 3036 Set_Etype (Id, Standard_Void_Type); 3037 Set_Contract (Id, Make_Contract (Sloc (Id))); 3038 3039 -- Analyze aspects now, so that generated pragmas appear in the 3040 -- declarations before building and analyzing the generic copy. 3041 3042 if Has_Aspects (N) then 3043 Analyze_Aspect_Specifications (N, Id); 3044 end if; 3045 3046 Push_Scope (Id); 3047 Enter_Generic_Scope (Id); 3048 Set_Inner_Instances (Id, New_Elmt_List); 3049 3050 Set_Categorization_From_Pragmas (N); 3051 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3052 3053 -- Link the declaration of the generic homonym in the generic copy to 3054 -- the package it renames, so that it is always resolved properly. 3055 3056 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3057 Set_Entity (Associated_Node (Name (Renaming)), Id); 3058 3059 -- For a library unit, we have reconstructed the entity for the unit, 3060 -- and must reset it in the library tables. 3061 3062 if Nkind (Parent (N)) = N_Compilation_Unit then 3063 Set_Cunit_Entity (Current_Sem_Unit, Id); 3064 end if; 3065 3066 Analyze_Generic_Formal_Part (N); 3067 3068 -- After processing the generic formals, analysis proceeds as for a 3069 -- non-generic package. 3070 3071 Analyze (Specification (N)); 3072 3073 Validate_Categorization_Dependency (N, Id); 3074 3075 End_Generic; 3076 3077 End_Package_Scope (Id); 3078 Exit_Generic_Scope (Id); 3079 3080 if Nkind (Parent (N)) /= N_Compilation_Unit then 3081 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3082 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3083 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3084 3085 else 3086 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3087 Validate_RT_RAT_Component (N); 3088 3089 -- If this is a spec without a body, check that generic parameters 3090 -- are referenced. 3091 3092 if not Body_Required (Parent (N)) then 3093 Check_References (Id); 3094 end if; 3095 end if; 3096 end Analyze_Generic_Package_Declaration; 3097 3098 -------------------------------------------- 3099 -- Analyze_Generic_Subprogram_Declaration -- 3100 -------------------------------------------- 3101 3102 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3103 Spec : Node_Id; 3104 Id : Entity_Id; 3105 Formals : List_Id; 3106 New_N : Node_Id; 3107 Result_Type : Entity_Id; 3108 Save_Parent : Node_Id; 3109 Typ : Entity_Id; 3110 3111 begin 3112 Check_SPARK_Restriction ("generic is not allowed", N); 3113 3114 -- Create copy of generic unit, and save for instantiation. If the unit 3115 -- is a child unit, do not copy the specifications for the parent, which 3116 -- are not part of the generic tree. 3117 3118 Save_Parent := Parent_Spec (N); 3119 Set_Parent_Spec (N, Empty); 3120 3121 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3122 Set_Parent_Spec (New_N, Save_Parent); 3123 Rewrite (N, New_N); 3124 3125 Check_SPARK_Mode_In_Generic (N); 3126 3127 -- The aspect specifications are not attached to the tree, and must 3128 -- be copied and attached to the generic copy explicitly. 3129 3130 if Present (Aspect_Specifications (New_N)) then 3131 declare 3132 Aspects : constant List_Id := Aspect_Specifications (N); 3133 begin 3134 Set_Has_Aspects (N, False); 3135 Move_Aspects (New_N, To => N); 3136 Set_Has_Aspects (Original_Node (N), False); 3137 Set_Aspect_Specifications (Original_Node (N), Aspects); 3138 end; 3139 end if; 3140 3141 Spec := Specification (N); 3142 Id := Defining_Entity (Spec); 3143 Generate_Definition (Id); 3144 Set_Contract (Id, Make_Contract (Sloc (Id))); 3145 3146 if Nkind (Id) = N_Defining_Operator_Symbol then 3147 Error_Msg_N 3148 ("operator symbol not allowed for generic subprogram", Id); 3149 end if; 3150 3151 Start_Generic; 3152 3153 Enter_Name (Id); 3154 3155 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3156 Push_Scope (Id); 3157 Enter_Generic_Scope (Id); 3158 Set_Inner_Instances (Id, New_Elmt_List); 3159 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3160 3161 Analyze_Generic_Formal_Part (N); 3162 3163 Formals := Parameter_Specifications (Spec); 3164 3165 if Present (Formals) then 3166 Process_Formals (Formals, Spec); 3167 end if; 3168 3169 if Nkind (Spec) = N_Function_Specification then 3170 Set_Ekind (Id, E_Generic_Function); 3171 3172 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3173 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3174 Set_Etype (Id, Result_Type); 3175 3176 -- Check restriction imposed by AI05-073: a generic function 3177 -- cannot return an abstract type or an access to such. 3178 3179 -- This is a binding interpretation should it apply to earlier 3180 -- versions of Ada as well as Ada 2012??? 3181 3182 if Is_Abstract_Type (Designated_Type (Result_Type)) 3183 and then Ada_Version >= Ada_2012 3184 then 3185 Error_Msg_N ("generic function cannot have an access result" 3186 & " that designates an abstract type", Spec); 3187 end if; 3188 3189 else 3190 Find_Type (Result_Definition (Spec)); 3191 Typ := Entity (Result_Definition (Spec)); 3192 3193 if Is_Abstract_Type (Typ) 3194 and then Ada_Version >= Ada_2012 3195 then 3196 Error_Msg_N 3197 ("generic function cannot have abstract result type", Spec); 3198 end if; 3199 3200 -- If a null exclusion is imposed on the result type, then create 3201 -- a null-excluding itype (an access subtype) and use it as the 3202 -- function's Etype. 3203 3204 if Is_Access_Type (Typ) 3205 and then Null_Exclusion_Present (Spec) 3206 then 3207 Set_Etype (Id, 3208 Create_Null_Excluding_Itype 3209 (T => Typ, 3210 Related_Nod => Spec, 3211 Scope_Id => Defining_Unit_Name (Spec))); 3212 else 3213 Set_Etype (Id, Typ); 3214 end if; 3215 end if; 3216 3217 else 3218 Set_Ekind (Id, E_Generic_Procedure); 3219 Set_Etype (Id, Standard_Void_Type); 3220 end if; 3221 3222 -- For a library unit, we have reconstructed the entity for the unit, 3223 -- and must reset it in the library tables. We also make sure that 3224 -- Body_Required is set properly in the original compilation unit node. 3225 3226 if Nkind (Parent (N)) = N_Compilation_Unit then 3227 Set_Cunit_Entity (Current_Sem_Unit, Id); 3228 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3229 end if; 3230 3231 Set_Categorization_From_Pragmas (N); 3232 Validate_Categorization_Dependency (N, Id); 3233 3234 Save_Global_References (Original_Node (N)); 3235 3236 -- For ASIS purposes, convert any postcondition, precondition pragmas 3237 -- into aspects, if N is not a compilation unit by itself, in order to 3238 -- enable the analysis of expressions inside the corresponding PPC 3239 -- pragmas. 3240 3241 if ASIS_Mode and then Is_List_Member (N) then 3242 Make_Aspect_For_PPC_In_Gen_Sub_Decl (N); 3243 end if; 3244 3245 -- To capture global references, analyze the expressions of aspects, 3246 -- and propagate information to original tree. Note that in this case 3247 -- analysis of attributes is not delayed until the freeze point. 3248 3249 -- It seems very hard to recreate the proper visibility of the generic 3250 -- subprogram at a later point because the analysis of an aspect may 3251 -- create pragmas after the generic copies have been made ??? 3252 3253 if Has_Aspects (N) then 3254 declare 3255 Aspect : Node_Id; 3256 3257 begin 3258 Aspect := First (Aspect_Specifications (N)); 3259 while Present (Aspect) loop 3260 if Get_Aspect_Id (Aspect) /= Aspect_Warnings 3261 and then Present (Expression (Aspect)) 3262 then 3263 Analyze (Expression (Aspect)); 3264 end if; 3265 3266 Next (Aspect); 3267 end loop; 3268 3269 Aspect := First (Aspect_Specifications (Original_Node (N))); 3270 while Present (Aspect) loop 3271 if Present (Expression (Aspect)) then 3272 Save_Global_References (Expression (Aspect)); 3273 end if; 3274 3275 Next (Aspect); 3276 end loop; 3277 end; 3278 end if; 3279 3280 End_Generic; 3281 End_Scope; 3282 Exit_Generic_Scope (Id); 3283 Generate_Reference_To_Formals (Id); 3284 3285 List_Inherited_Pre_Post_Aspects (Id); 3286 end Analyze_Generic_Subprogram_Declaration; 3287 3288 ----------------------------------- 3289 -- Analyze_Package_Instantiation -- 3290 ----------------------------------- 3291 3292 procedure Analyze_Package_Instantiation (N : Node_Id) is 3293 Loc : constant Source_Ptr := Sloc (N); 3294 Gen_Id : constant Node_Id := Name (N); 3295 3296 Act_Decl : Node_Id; 3297 Act_Decl_Name : Node_Id; 3298 Act_Decl_Id : Entity_Id; 3299 Act_Spec : Node_Id; 3300 Act_Tree : Node_Id; 3301 3302 Gen_Decl : Node_Id; 3303 Gen_Unit : Entity_Id; 3304 3305 Is_Actual_Pack : constant Boolean := 3306 Is_Internal (Defining_Entity (N)); 3307 3308 Env_Installed : Boolean := False; 3309 Parent_Installed : Boolean := False; 3310 Renaming_List : List_Id; 3311 Unit_Renaming : Node_Id; 3312 Needs_Body : Boolean; 3313 Inline_Now : Boolean := False; 3314 3315 Save_Style_Check : constant Boolean := Style_Check; 3316 -- Save style check mode for restore on exit 3317 3318 procedure Delay_Descriptors (E : Entity_Id); 3319 -- Delay generation of subprogram descriptors for given entity 3320 3321 function Might_Inline_Subp return Boolean; 3322 -- If inlining is active and the generic contains inlined subprograms, 3323 -- we instantiate the body. This may cause superfluous instantiations, 3324 -- but it is simpler than detecting the need for the body at the point 3325 -- of inlining, when the context of the instance is not available. 3326 3327 function Must_Inline_Subp return Boolean; 3328 -- If inlining is active and the generic contains inlined subprograms, 3329 -- return True if some of the inlined subprograms must be inlined by 3330 -- the frontend. 3331 3332 ----------------------- 3333 -- Delay_Descriptors -- 3334 ----------------------- 3335 3336 procedure Delay_Descriptors (E : Entity_Id) is 3337 begin 3338 if not Delay_Subprogram_Descriptors (E) then 3339 Set_Delay_Subprogram_Descriptors (E); 3340 Pending_Descriptor.Append (E); 3341 end if; 3342 end Delay_Descriptors; 3343 3344 ----------------------- 3345 -- Might_Inline_Subp -- 3346 ----------------------- 3347 3348 function Might_Inline_Subp return Boolean is 3349 E : Entity_Id; 3350 3351 begin 3352 if not Inline_Processing_Required then 3353 return False; 3354 3355 else 3356 E := First_Entity (Gen_Unit); 3357 while Present (E) loop 3358 if Is_Subprogram (E) 3359 and then Is_Inlined (E) 3360 then 3361 return True; 3362 end if; 3363 3364 Next_Entity (E); 3365 end loop; 3366 end if; 3367 3368 return False; 3369 end Might_Inline_Subp; 3370 3371 ---------------------- 3372 -- Must_Inline_Subp -- 3373 ---------------------- 3374 3375 function Must_Inline_Subp return Boolean is 3376 E : Entity_Id; 3377 3378 begin 3379 if not Inline_Processing_Required then 3380 return False; 3381 3382 else 3383 E := First_Entity (Gen_Unit); 3384 while Present (E) loop 3385 if Is_Subprogram (E) 3386 and then Is_Inlined (E) 3387 and then Must_Inline (E) 3388 then 3389 return True; 3390 end if; 3391 3392 Next_Entity (E); 3393 end loop; 3394 end if; 3395 3396 return False; 3397 end Must_Inline_Subp; 3398 3399 -- Local declarations 3400 3401 Vis_Prims_List : Elist_Id := No_Elist; 3402 -- List of primitives made temporarily visible in the instantiation 3403 -- to match the visibility of the formal type 3404 3405 -- Start of processing for Analyze_Package_Instantiation 3406 3407 begin 3408 Check_SPARK_Restriction ("generic is not allowed", N); 3409 3410 -- Very first thing: apply the special kludge for Text_IO processing 3411 -- in case we are instantiating one of the children of [Wide_]Text_IO. 3412 3413 Text_IO_Kludge (Name (N)); 3414 3415 -- Make node global for error reporting 3416 3417 Instantiation_Node := N; 3418 3419 -- Turn off style checking in instances. If the check is enabled on the 3420 -- generic unit, a warning in an instance would just be noise. If not 3421 -- enabled on the generic, then a warning in an instance is just wrong. 3422 3423 Style_Check := False; 3424 3425 -- Case of instantiation of a generic package 3426 3427 if Nkind (N) = N_Package_Instantiation then 3428 Act_Decl_Id := New_Copy (Defining_Entity (N)); 3429 Set_Comes_From_Source (Act_Decl_Id, True); 3430 3431 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 3432 Act_Decl_Name := 3433 Make_Defining_Program_Unit_Name (Loc, 3434 Name => New_Copy_Tree (Name (Defining_Unit_Name (N))), 3435 Defining_Identifier => Act_Decl_Id); 3436 else 3437 Act_Decl_Name := Act_Decl_Id; 3438 end if; 3439 3440 -- Case of instantiation of a formal package 3441 3442 else 3443 Act_Decl_Id := Defining_Identifier (N); 3444 Act_Decl_Name := Act_Decl_Id; 3445 end if; 3446 3447 Generate_Definition (Act_Decl_Id); 3448 Preanalyze_Actuals (N); 3449 3450 Init_Env; 3451 Env_Installed := True; 3452 3453 -- Reset renaming map for formal types. The mapping is established 3454 -- when analyzing the generic associations, but some mappings are 3455 -- inherited from formal packages of parent units, and these are 3456 -- constructed when the parents are installed. 3457 3458 Generic_Renamings.Set_Last (0); 3459 Generic_Renamings_HTable.Reset; 3460 3461 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 3462 Gen_Unit := Entity (Gen_Id); 3463 3464 -- Verify that it is the name of a generic package 3465 3466 -- A visibility glitch: if the instance is a child unit and the generic 3467 -- is the generic unit of a parent instance (i.e. both the parent and 3468 -- the child units are instances of the same package) the name now 3469 -- denotes the renaming within the parent, not the intended generic 3470 -- unit. See if there is a homonym that is the desired generic. The 3471 -- renaming declaration must be visible inside the instance of the 3472 -- child, but not when analyzing the name in the instantiation itself. 3473 3474 if Ekind (Gen_Unit) = E_Package 3475 and then Present (Renamed_Entity (Gen_Unit)) 3476 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 3477 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 3478 and then Present (Homonym (Gen_Unit)) 3479 then 3480 Gen_Unit := Homonym (Gen_Unit); 3481 end if; 3482 3483 if Etype (Gen_Unit) = Any_Type then 3484 Restore_Env; 3485 goto Leave; 3486 3487 elsif Ekind (Gen_Unit) /= E_Generic_Package then 3488 3489 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 3490 3491 if From_Limited_With (Gen_Unit) then 3492 Error_Msg_N 3493 ("cannot instantiate a limited withed package", Gen_Id); 3494 else 3495 Error_Msg_NE 3496 ("& is not the name of a generic package", Gen_Id, Gen_Unit); 3497 end if; 3498 3499 Restore_Env; 3500 goto Leave; 3501 end if; 3502 3503 if In_Extended_Main_Source_Unit (N) then 3504 Set_Is_Instantiated (Gen_Unit); 3505 Generate_Reference (Gen_Unit, N); 3506 3507 if Present (Renamed_Object (Gen_Unit)) then 3508 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 3509 Generate_Reference (Renamed_Object (Gen_Unit), N); 3510 end if; 3511 end if; 3512 3513 if Nkind (Gen_Id) = N_Identifier 3514 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 3515 then 3516 Error_Msg_NE 3517 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 3518 3519 elsif Nkind (Gen_Id) = N_Expanded_Name 3520 and then Is_Child_Unit (Gen_Unit) 3521 and then Nkind (Prefix (Gen_Id)) = N_Identifier 3522 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 3523 then 3524 Error_Msg_N 3525 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 3526 end if; 3527 3528 Set_Entity (Gen_Id, Gen_Unit); 3529 3530 -- If generic is a renaming, get original generic unit 3531 3532 if Present (Renamed_Object (Gen_Unit)) 3533 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 3534 then 3535 Gen_Unit := Renamed_Object (Gen_Unit); 3536 end if; 3537 3538 -- Verify that there are no circular instantiations 3539 3540 if In_Open_Scopes (Gen_Unit) then 3541 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 3542 Restore_Env; 3543 goto Leave; 3544 3545 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 3546 Error_Msg_Node_2 := Current_Scope; 3547 Error_Msg_NE 3548 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 3549 Circularity_Detected := True; 3550 Restore_Env; 3551 goto Leave; 3552 3553 else 3554 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 3555 3556 -- Initialize renamings map, for error checking, and the list that 3557 -- holds private entities whose views have changed between generic 3558 -- definition and instantiation. If this is the instance created to 3559 -- validate an actual package, the instantiation environment is that 3560 -- of the enclosing instance. 3561 3562 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 3563 3564 -- Copy original generic tree, to produce text for instantiation 3565 3566 Act_Tree := 3567 Copy_Generic_Node 3568 (Original_Node (Gen_Decl), Empty, Instantiating => True); 3569 3570 Act_Spec := Specification (Act_Tree); 3571 3572 -- If this is the instance created to validate an actual package, 3573 -- only the formals matter, do not examine the package spec itself. 3574 3575 if Is_Actual_Pack then 3576 Set_Visible_Declarations (Act_Spec, New_List); 3577 Set_Private_Declarations (Act_Spec, New_List); 3578 end if; 3579 3580 Renaming_List := 3581 Analyze_Associations 3582 (I_Node => N, 3583 Formals => Generic_Formal_Declarations (Act_Tree), 3584 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 3585 3586 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 3587 3588 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 3589 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 3590 Set_Is_Generic_Instance (Act_Decl_Id); 3591 3592 Set_Generic_Parent (Act_Spec, Gen_Unit); 3593 3594 -- References to the generic in its own declaration or its body are 3595 -- references to the instance. Add a renaming declaration for the 3596 -- generic unit itself. This declaration, as well as the renaming 3597 -- declarations for the generic formals, must remain private to the 3598 -- unit: the formals, because this is the language semantics, and 3599 -- the unit because its use is an artifact of the implementation. 3600 3601 Unit_Renaming := 3602 Make_Package_Renaming_Declaration (Loc, 3603 Defining_Unit_Name => 3604 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 3605 Name => New_Occurrence_Of (Act_Decl_Id, Loc)); 3606 3607 Append (Unit_Renaming, Renaming_List); 3608 3609 -- The renaming declarations are the first local declarations of the 3610 -- new unit. 3611 3612 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 3613 Insert_List_Before 3614 (First (Visible_Declarations (Act_Spec)), Renaming_List); 3615 else 3616 Set_Visible_Declarations (Act_Spec, Renaming_List); 3617 end if; 3618 3619 Act_Decl := 3620 Make_Package_Declaration (Loc, 3621 Specification => Act_Spec); 3622 3623 -- Propagate the aspect specifications from the package declaration 3624 -- template to the instantiated version of the package declaration. 3625 3626 if Has_Aspects (Act_Tree) then 3627 Set_Aspect_Specifications (Act_Decl, 3628 New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); 3629 end if; 3630 3631 -- Save the instantiation node, for subsequent instantiation of the 3632 -- body, if there is one and we are generating code for the current 3633 -- unit. Mark unit as having a body (avoids premature error message). 3634 3635 -- We instantiate the body if we are generating code, if we are 3636 -- generating cross-reference information, or if we are building 3637 -- trees for ASIS use or GNATprove use. 3638 3639 declare 3640 Enclosing_Body_Present : Boolean := False; 3641 -- If the generic unit is not a compilation unit, then a body may 3642 -- be present in its parent even if none is required. We create a 3643 -- tentative pending instantiation for the body, which will be 3644 -- discarded if none is actually present. 3645 3646 Scop : Entity_Id; 3647 3648 begin 3649 if Scope (Gen_Unit) /= Standard_Standard 3650 and then not Is_Child_Unit (Gen_Unit) 3651 then 3652 Scop := Scope (Gen_Unit); 3653 3654 while Present (Scop) 3655 and then Scop /= Standard_Standard 3656 loop 3657 if Unit_Requires_Body (Scop) then 3658 Enclosing_Body_Present := True; 3659 exit; 3660 3661 elsif In_Open_Scopes (Scop) 3662 and then In_Package_Body (Scop) 3663 then 3664 Enclosing_Body_Present := True; 3665 exit; 3666 end if; 3667 3668 exit when Is_Compilation_Unit (Scop); 3669 Scop := Scope (Scop); 3670 end loop; 3671 end if; 3672 3673 -- If front-end inlining is enabled, and this is a unit for which 3674 -- code will be generated, we instantiate the body at once. 3675 3676 -- This is done if the instance is not the main unit, and if the 3677 -- generic is not a child unit of another generic, to avoid scope 3678 -- problems and the reinstallation of parent instances. 3679 3680 if Expander_Active 3681 and then (not Is_Child_Unit (Gen_Unit) 3682 or else not Is_Generic_Unit (Scope (Gen_Unit))) 3683 and then Might_Inline_Subp 3684 and then not Is_Actual_Pack 3685 then 3686 if not Debug_Flag_Dot_K 3687 and then Front_End_Inlining 3688 and then (Is_In_Main_Unit (N) 3689 or else In_Main_Context (Current_Scope)) 3690 and then Nkind (Parent (N)) /= N_Compilation_Unit 3691 then 3692 Inline_Now := True; 3693 3694 elsif Debug_Flag_Dot_K 3695 and then Must_Inline_Subp 3696 and then (Is_In_Main_Unit (N) 3697 or else In_Main_Context (Current_Scope)) 3698 and then Nkind (Parent (N)) /= N_Compilation_Unit 3699 then 3700 Inline_Now := True; 3701 3702 -- In configurable_run_time mode we force the inlining of 3703 -- predefined subprograms marked Inline_Always, to minimize 3704 -- the use of the run-time library. 3705 3706 elsif Is_Predefined_File_Name 3707 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 3708 and then Configurable_Run_Time_Mode 3709 and then Nkind (Parent (N)) /= N_Compilation_Unit 3710 then 3711 Inline_Now := True; 3712 end if; 3713 3714 -- If the current scope is itself an instance within a child 3715 -- unit, there will be duplications in the scope stack, and the 3716 -- unstacking mechanism in Inline_Instance_Body will fail. 3717 -- This loses some rare cases of optimization, and might be 3718 -- improved some day, if we can find a proper abstraction for 3719 -- "the complete compilation context" that can be saved and 3720 -- restored. ??? 3721 3722 if Is_Generic_Instance (Current_Scope) then 3723 declare 3724 Curr_Unit : constant Entity_Id := 3725 Cunit_Entity (Current_Sem_Unit); 3726 begin 3727 if Curr_Unit /= Current_Scope 3728 and then Is_Child_Unit (Curr_Unit) 3729 then 3730 Inline_Now := False; 3731 end if; 3732 end; 3733 end if; 3734 end if; 3735 3736 Needs_Body := 3737 (Unit_Requires_Body (Gen_Unit) 3738 or else Enclosing_Body_Present 3739 or else Present (Corresponding_Body (Gen_Decl))) 3740 and then (Is_In_Main_Unit (N) or else Might_Inline_Subp) 3741 and then not Is_Actual_Pack 3742 and then not Inline_Now 3743 and then (Operating_Mode = Generate_Code 3744 3745 -- Need comment for this check ??? 3746 3747 or else (Operating_Mode = Check_Semantics 3748 and then (ASIS_Mode or GNATprove_Mode))); 3749 3750 -- If front_end_inlining is enabled, do not instantiate body if 3751 -- within a generic context. 3752 3753 if (Front_End_Inlining and then not Expander_Active) 3754 or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) 3755 then 3756 Needs_Body := False; 3757 end if; 3758 3759 -- If the current context is generic, and the package being 3760 -- instantiated is declared within a formal package, there is no 3761 -- body to instantiate until the enclosing generic is instantiated 3762 -- and there is an actual for the formal package. If the formal 3763 -- package has parameters, we build a regular package instance for 3764 -- it, that precedes the original formal package declaration. 3765 3766 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 3767 declare 3768 Decl : constant Node_Id := 3769 Original_Node 3770 (Unit_Declaration_Node (Scope (Gen_Unit))); 3771 begin 3772 if Nkind (Decl) = N_Formal_Package_Declaration 3773 or else (Nkind (Decl) = N_Package_Declaration 3774 and then Is_List_Member (Decl) 3775 and then Present (Next (Decl)) 3776 and then 3777 Nkind (Next (Decl)) = 3778 N_Formal_Package_Declaration) 3779 then 3780 Needs_Body := False; 3781 end if; 3782 end; 3783 end if; 3784 end; 3785 3786 -- For RCI unit calling stubs, we omit the instance body if the 3787 -- instance is the RCI library unit itself. 3788 3789 -- However there is a special case for nested instances: in this case 3790 -- we do generate the instance body, as it might be required, e.g. 3791 -- because it provides stream attributes for some type used in the 3792 -- profile of a remote subprogram. This is consistent with 12.3(12), 3793 -- which indicates that the instance body occurs at the place of the 3794 -- instantiation, and thus is part of the RCI declaration, which is 3795 -- present on all client partitions (this is E.2.3(18)). 3796 3797 -- Note that AI12-0002 may make it illegal at some point to have 3798 -- stream attributes defined in an RCI unit, in which case this 3799 -- special case will become unnecessary. In the meantime, there 3800 -- is known application code in production that depends on this 3801 -- being possible, so we definitely cannot eliminate the body in 3802 -- the case of nested instances for the time being. 3803 3804 -- When we generate a nested instance body, calling stubs for any 3805 -- relevant subprogram will be be inserted immediately after the 3806 -- subprogram declarations, and will take precedence over the 3807 -- subsequent (original) body. (The stub and original body will be 3808 -- complete homographs, but this is permitted in an instance). 3809 -- (Could we do better and remove the original body???) 3810 3811 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 3812 and then Comes_From_Source (N) 3813 and then Nkind (Parent (N)) = N_Compilation_Unit 3814 then 3815 Needs_Body := False; 3816 end if; 3817 3818 if Needs_Body then 3819 3820 -- Here is a defence against a ludicrous number of instantiations 3821 -- caused by a circular set of instantiation attempts. 3822 3823 if Pending_Instantiations.Last > Maximum_Instantiations then 3824 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 3825 Error_Msg_N ("too many instantiations, exceeds max of^", N); 3826 Error_Msg_N ("\limit can be changed using -gnateinn switch", N); 3827 raise Unrecoverable_Error; 3828 end if; 3829 3830 -- Indicate that the enclosing scopes contain an instantiation, 3831 -- and that cleanup actions should be delayed until after the 3832 -- instance body is expanded. 3833 3834 Check_Forward_Instantiation (Gen_Decl); 3835 if Nkind (N) = N_Package_Instantiation then 3836 declare 3837 Enclosing_Master : Entity_Id; 3838 3839 begin 3840 -- Loop to search enclosing masters 3841 3842 Enclosing_Master := Current_Scope; 3843 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 3844 if Ekind (Enclosing_Master) = E_Package then 3845 if Is_Compilation_Unit (Enclosing_Master) then 3846 if In_Package_Body (Enclosing_Master) then 3847 Delay_Descriptors 3848 (Body_Entity (Enclosing_Master)); 3849 else 3850 Delay_Descriptors 3851 (Enclosing_Master); 3852 end if; 3853 3854 exit Scope_Loop; 3855 3856 else 3857 Enclosing_Master := Scope (Enclosing_Master); 3858 end if; 3859 3860 elsif Is_Generic_Unit (Enclosing_Master) 3861 or else Ekind (Enclosing_Master) = E_Void 3862 then 3863 -- Cleanup actions will eventually be performed on the 3864 -- enclosing subprogram or package instance, if any. 3865 -- Enclosing scope is void in the formal part of a 3866 -- generic subprogram. 3867 3868 exit Scope_Loop; 3869 3870 else 3871 if Ekind (Enclosing_Master) = E_Entry 3872 and then 3873 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 3874 then 3875 if not Expander_Active then 3876 exit Scope_Loop; 3877 else 3878 Enclosing_Master := 3879 Protected_Body_Subprogram (Enclosing_Master); 3880 end if; 3881 end if; 3882 3883 Set_Delay_Cleanups (Enclosing_Master); 3884 3885 while Ekind (Enclosing_Master) = E_Block loop 3886 Enclosing_Master := Scope (Enclosing_Master); 3887 end loop; 3888 3889 if Is_Subprogram (Enclosing_Master) then 3890 Delay_Descriptors (Enclosing_Master); 3891 3892 elsif Is_Task_Type (Enclosing_Master) then 3893 declare 3894 TBP : constant Node_Id := 3895 Get_Task_Body_Procedure 3896 (Enclosing_Master); 3897 begin 3898 if Present (TBP) then 3899 Delay_Descriptors (TBP); 3900 Set_Delay_Cleanups (TBP); 3901 end if; 3902 end; 3903 end if; 3904 3905 exit Scope_Loop; 3906 end if; 3907 end loop Scope_Loop; 3908 end; 3909 3910 -- Make entry in table 3911 3912 Pending_Instantiations.Append 3913 ((Inst_Node => N, 3914 Act_Decl => Act_Decl, 3915 Expander_Status => Expander_Active, 3916 Current_Sem_Unit => Current_Sem_Unit, 3917 Scope_Suppress => Scope_Suppress, 3918 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 3919 Version => Ada_Version, 3920 Version_Pragma => Ada_Version_Pragma, 3921 Warnings => Save_Warnings, 3922 SPARK_Mode => SPARK_Mode, 3923 SPARK_Mode_Pragma => SPARK_Mode_Pragma)); 3924 end if; 3925 end if; 3926 3927 Set_Categorization_From_Pragmas (Act_Decl); 3928 3929 if Parent_Installed then 3930 Hide_Current_Scope; 3931 end if; 3932 3933 Set_Instance_Spec (N, Act_Decl); 3934 3935 -- If not a compilation unit, insert the package declaration before 3936 -- the original instantiation node. 3937 3938 if Nkind (Parent (N)) /= N_Compilation_Unit then 3939 Mark_Rewrite_Insertion (Act_Decl); 3940 Insert_Before (N, Act_Decl); 3941 Analyze (Act_Decl); 3942 3943 -- For an instantiation that is a compilation unit, place 3944 -- declaration on current node so context is complete for analysis 3945 -- (including nested instantiations). If this is the main unit, 3946 -- the declaration eventually replaces the instantiation node. 3947 -- If the instance body is created later, it replaces the 3948 -- instance node, and the declaration is attached to it 3949 -- (see Build_Instance_Compilation_Unit_Nodes). 3950 3951 else 3952 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 3953 3954 -- The entity for the current unit is the newly created one, 3955 -- and all semantic information is attached to it. 3956 3957 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 3958 3959 -- If this is the main unit, replace the main entity as well 3960 3961 if Current_Sem_Unit = Main_Unit then 3962 Main_Unit_Entity := Act_Decl_Id; 3963 end if; 3964 end if; 3965 3966 Set_Unit (Parent (N), Act_Decl); 3967 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 3968 Set_Package_Instantiation (Act_Decl_Id, N); 3969 3970 -- Process aspect specifications of the instance node, if any, to 3971 -- take into account categorization pragmas before analyzing the 3972 -- instance. 3973 3974 if Has_Aspects (N) then 3975 Analyze_Aspect_Specifications (N, Act_Decl_Id); 3976 end if; 3977 3978 Analyze (Act_Decl); 3979 Set_Unit (Parent (N), N); 3980 Set_Body_Required (Parent (N), False); 3981 3982 -- We never need elaboration checks on instantiations, since by 3983 -- definition, the body instantiation is elaborated at the same 3984 -- time as the spec instantiation. 3985 3986 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 3987 Set_Kill_Elaboration_Checks (Act_Decl_Id); 3988 end if; 3989 3990 Check_Elab_Instantiation (N); 3991 3992 if ABE_Is_Certain (N) and then Needs_Body then 3993 Pending_Instantiations.Decrement_Last; 3994 end if; 3995 3996 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 3997 3998 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 3999 First_Private_Entity (Act_Decl_Id)); 4000 4001 -- If the instantiation will receive a body, the unit will be 4002 -- transformed into a package body, and receive its own elaboration 4003 -- entity. Otherwise, the nature of the unit is now a package 4004 -- declaration. 4005 4006 if Nkind (Parent (N)) = N_Compilation_Unit 4007 and then not Needs_Body 4008 then 4009 Rewrite (N, Act_Decl); 4010 end if; 4011 4012 if Present (Corresponding_Body (Gen_Decl)) 4013 or else Unit_Requires_Body (Gen_Unit) 4014 then 4015 Set_Has_Completion (Act_Decl_Id); 4016 end if; 4017 4018 Check_Formal_Packages (Act_Decl_Id); 4019 4020 Restore_Hidden_Primitives (Vis_Prims_List); 4021 Restore_Private_Views (Act_Decl_Id); 4022 4023 Inherit_Context (Gen_Decl, N); 4024 4025 if Parent_Installed then 4026 Remove_Parent; 4027 end if; 4028 4029 Restore_Env; 4030 Env_Installed := False; 4031 end if; 4032 4033 Validate_Categorization_Dependency (N, Act_Decl_Id); 4034 4035 -- There used to be a check here to prevent instantiations in local 4036 -- contexts if the No_Local_Allocators restriction was active. This 4037 -- check was removed by a binding interpretation in AI-95-00130/07, 4038 -- but we retain the code for documentation purposes. 4039 4040 -- if Ekind (Act_Decl_Id) /= E_Void 4041 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4042 -- then 4043 -- Check_Restriction (No_Local_Allocators, N); 4044 -- end if; 4045 4046 if Inline_Now then 4047 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4048 end if; 4049 4050 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4051 -- be used as defining identifiers for a formal package and for the 4052 -- corresponding expanded package. 4053 4054 if Nkind (N) = N_Formal_Package_Declaration then 4055 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4056 Set_Comes_From_Source (Act_Decl_Id, True); 4057 Set_Is_Generic_Instance (Act_Decl_Id, False); 4058 Set_Defining_Identifier (N, Act_Decl_Id); 4059 end if; 4060 4061 Style_Check := Save_Style_Check; 4062 4063 -- Check that if N is an instantiation of System.Dim_Float_IO or 4064 -- System.Dim_Integer_IO, the formal type has a dimension system. 4065 4066 if Nkind (N) = N_Package_Instantiation 4067 and then Is_Dim_IO_Package_Instantiation (N) 4068 then 4069 declare 4070 Assoc : constant Node_Id := First (Generic_Associations (N)); 4071 begin 4072 if not Has_Dimension_System 4073 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4074 then 4075 Error_Msg_N ("type with a dimension system expected", Assoc); 4076 end if; 4077 end; 4078 end if; 4079 4080 <<Leave>> 4081 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then 4082 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4083 end if; 4084 4085 exception 4086 when Instantiation_Error => 4087 if Parent_Installed then 4088 Remove_Parent; 4089 end if; 4090 4091 if Env_Installed then 4092 Restore_Env; 4093 end if; 4094 4095 Style_Check := Save_Style_Check; 4096 end Analyze_Package_Instantiation; 4097 4098 -------------------------- 4099 -- Inline_Instance_Body -- 4100 -------------------------- 4101 4102 procedure Inline_Instance_Body 4103 (N : Node_Id; 4104 Gen_Unit : Entity_Id; 4105 Act_Decl : Node_Id) 4106 is 4107 Vis : Boolean; 4108 Gen_Comp : constant Entity_Id := 4109 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4110 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4111 Curr_Scope : Entity_Id := Empty; 4112 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4113 Removed : Boolean := False; 4114 Num_Scopes : Int := 0; 4115 4116 Scope_Stack_Depth : constant Int := 4117 Scope_Stack.Last - Scope_Stack.First + 1; 4118 4119 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4120 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4121 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4122 List : Elist_Id; 4123 Num_Inner : Int := 0; 4124 N_Instances : Int := 0; 4125 S : Entity_Id; 4126 4127 begin 4128 -- Case of generic unit defined in another unit. We must remove the 4129 -- complete context of the current unit to install that of the generic. 4130 4131 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4132 4133 -- Add some comments for the following two loops ??? 4134 4135 S := Current_Scope; 4136 while Present (S) and then S /= Standard_Standard loop 4137 loop 4138 Num_Scopes := Num_Scopes + 1; 4139 4140 Use_Clauses (Num_Scopes) := 4141 (Scope_Stack.Table 4142 (Scope_Stack.Last - Num_Scopes + 1). 4143 First_Use_Clause); 4144 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4145 4146 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4147 or else Scope_Stack.Table 4148 (Scope_Stack.Last - Num_Scopes).Entity 4149 = Scope (S); 4150 end loop; 4151 4152 exit when Is_Generic_Instance (S) 4153 and then (In_Package_Body (S) 4154 or else Ekind (S) = E_Procedure 4155 or else Ekind (S) = E_Function); 4156 S := Scope (S); 4157 end loop; 4158 4159 Vis := Is_Immediately_Visible (Gen_Comp); 4160 4161 -- Find and save all enclosing instances 4162 4163 S := Current_Scope; 4164 4165 while Present (S) 4166 and then S /= Standard_Standard 4167 loop 4168 if Is_Generic_Instance (S) then 4169 N_Instances := N_Instances + 1; 4170 Instances (N_Instances) := S; 4171 4172 exit when In_Package_Body (S); 4173 end if; 4174 4175 S := Scope (S); 4176 end loop; 4177 4178 -- Remove context of current compilation unit, unless we are within a 4179 -- nested package instantiation, in which case the context has been 4180 -- removed previously. 4181 4182 -- If current scope is the body of a child unit, remove context of 4183 -- spec as well. If an enclosing scope is an instance body, the 4184 -- context has already been removed, but the entities in the body 4185 -- must be made invisible as well. 4186 4187 S := Current_Scope; 4188 4189 while Present (S) 4190 and then S /= Standard_Standard 4191 loop 4192 if Is_Generic_Instance (S) 4193 and then (In_Package_Body (S) 4194 or else Ekind (S) = E_Procedure 4195 or else Ekind (S) = E_Function) 4196 then 4197 -- We still have to remove the entities of the enclosing 4198 -- instance from direct visibility. 4199 4200 declare 4201 E : Entity_Id; 4202 begin 4203 E := First_Entity (S); 4204 while Present (E) loop 4205 Set_Is_Immediately_Visible (E, False); 4206 Next_Entity (E); 4207 end loop; 4208 end; 4209 4210 exit; 4211 end if; 4212 4213 if S = Curr_Unit 4214 or else (Ekind (Curr_Unit) = E_Package_Body 4215 and then S = Spec_Entity (Curr_Unit)) 4216 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4217 and then S = 4218 Corresponding_Spec 4219 (Unit_Declaration_Node (Curr_Unit))) 4220 then 4221 Removed := True; 4222 4223 -- Remove entities in current scopes from visibility, so that 4224 -- instance body is compiled in a clean environment. 4225 4226 List := Save_Scope_Stack (Handle_Use => False); 4227 4228 if Is_Child_Unit (S) then 4229 4230 -- Remove child unit from stack, as well as inner scopes. 4231 -- Removing the context of a child unit removes parent units 4232 -- as well. 4233 4234 while Current_Scope /= S loop 4235 Num_Inner := Num_Inner + 1; 4236 Inner_Scopes (Num_Inner) := Current_Scope; 4237 Pop_Scope; 4238 end loop; 4239 4240 Pop_Scope; 4241 Remove_Context (Curr_Comp); 4242 Curr_Scope := S; 4243 4244 else 4245 Remove_Context (Curr_Comp); 4246 end if; 4247 4248 if Ekind (Curr_Unit) = E_Package_Body then 4249 Remove_Context (Library_Unit (Curr_Comp)); 4250 end if; 4251 end if; 4252 4253 S := Scope (S); 4254 end loop; 4255 pragma Assert (Num_Inner < Num_Scopes); 4256 4257 Push_Scope (Standard_Standard); 4258 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 4259 Instantiate_Package_Body 4260 (Body_Info => 4261 ((Inst_Node => N, 4262 Act_Decl => Act_Decl, 4263 Expander_Status => Expander_Active, 4264 Current_Sem_Unit => Current_Sem_Unit, 4265 Scope_Suppress => Scope_Suppress, 4266 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4267 Version => Ada_Version, 4268 Version_Pragma => Ada_Version_Pragma, 4269 Warnings => Save_Warnings, 4270 SPARK_Mode => SPARK_Mode, 4271 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 4272 Inlined_Body => True); 4273 4274 Pop_Scope; 4275 4276 -- Restore context 4277 4278 Set_Is_Immediately_Visible (Gen_Comp, Vis); 4279 4280 -- Reset Generic_Instance flag so that use clauses can be installed 4281 -- in the proper order. (See Use_One_Package for effect of enclosing 4282 -- instances on processing of use clauses). 4283 4284 for J in 1 .. N_Instances loop 4285 Set_Is_Generic_Instance (Instances (J), False); 4286 end loop; 4287 4288 if Removed then 4289 Install_Context (Curr_Comp); 4290 4291 if Present (Curr_Scope) 4292 and then Is_Child_Unit (Curr_Scope) 4293 then 4294 Push_Scope (Curr_Scope); 4295 Set_Is_Immediately_Visible (Curr_Scope); 4296 4297 -- Finally, restore inner scopes as well 4298 4299 for J in reverse 1 .. Num_Inner loop 4300 Push_Scope (Inner_Scopes (J)); 4301 end loop; 4302 end if; 4303 4304 Restore_Scope_Stack (List, Handle_Use => False); 4305 4306 if Present (Curr_Scope) 4307 and then 4308 (In_Private_Part (Curr_Scope) 4309 or else In_Package_Body (Curr_Scope)) 4310 then 4311 -- Install private declaration of ancestor units, which are 4312 -- currently available. Restore_Scope_Stack and Install_Context 4313 -- only install the visible part of parents. 4314 4315 declare 4316 Par : Entity_Id; 4317 begin 4318 Par := Scope (Curr_Scope); 4319 while (Present (Par)) 4320 and then Par /= Standard_Standard 4321 loop 4322 Install_Private_Declarations (Par); 4323 Par := Scope (Par); 4324 end loop; 4325 end; 4326 end if; 4327 end if; 4328 4329 -- Restore use clauses. For a child unit, use clauses in the parents 4330 -- are restored when installing the context, so only those in inner 4331 -- scopes (and those local to the child unit itself) need to be 4332 -- installed explicitly. 4333 4334 if Is_Child_Unit (Curr_Unit) 4335 and then Removed 4336 then 4337 for J in reverse 1 .. Num_Inner + 1 loop 4338 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4339 Use_Clauses (J); 4340 Install_Use_Clauses (Use_Clauses (J)); 4341 end loop; 4342 4343 else 4344 for J in reverse 1 .. Num_Scopes loop 4345 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 4346 Use_Clauses (J); 4347 Install_Use_Clauses (Use_Clauses (J)); 4348 end loop; 4349 end if; 4350 4351 -- Restore status of instances. If one of them is a body, make its 4352 -- local entities visible again. 4353 4354 declare 4355 E : Entity_Id; 4356 Inst : Entity_Id; 4357 4358 begin 4359 for J in 1 .. N_Instances loop 4360 Inst := Instances (J); 4361 Set_Is_Generic_Instance (Inst, True); 4362 4363 if In_Package_Body (Inst) 4364 or else Ekind (S) = E_Procedure 4365 or else Ekind (S) = E_Function 4366 then 4367 E := First_Entity (Instances (J)); 4368 while Present (E) loop 4369 Set_Is_Immediately_Visible (E); 4370 Next_Entity (E); 4371 end loop; 4372 end if; 4373 end loop; 4374 end; 4375 4376 -- If generic unit is in current unit, current context is correct 4377 4378 else 4379 Instantiate_Package_Body 4380 (Body_Info => 4381 ((Inst_Node => N, 4382 Act_Decl => Act_Decl, 4383 Expander_Status => Expander_Active, 4384 Current_Sem_Unit => Current_Sem_Unit, 4385 Scope_Suppress => Scope_Suppress, 4386 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4387 Version => Ada_Version, 4388 Version_Pragma => Ada_Version_Pragma, 4389 Warnings => Save_Warnings, 4390 SPARK_Mode => SPARK_Mode, 4391 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 4392 Inlined_Body => True); 4393 end if; 4394 end Inline_Instance_Body; 4395 4396 ------------------------------------- 4397 -- Analyze_Procedure_Instantiation -- 4398 ------------------------------------- 4399 4400 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 4401 begin 4402 Analyze_Subprogram_Instantiation (N, E_Procedure); 4403 end Analyze_Procedure_Instantiation; 4404 4405 ----------------------------------- 4406 -- Need_Subprogram_Instance_Body -- 4407 ----------------------------------- 4408 4409 function Need_Subprogram_Instance_Body 4410 (N : Node_Id; 4411 Subp : Entity_Id) return Boolean 4412 is 4413 begin 4414 -- Must be inlined (or inlined renaming) 4415 4416 if (Is_In_Main_Unit (N) 4417 or else Is_Inlined (Subp) 4418 or else Is_Inlined (Alias (Subp))) 4419 4420 -- Must be generating code or analyzing code in ASIS/GNATprove mode 4421 4422 and then (Operating_Mode = Generate_Code 4423 or else (Operating_Mode = Check_Semantics 4424 and then (ASIS_Mode or GNATprove_Mode))) 4425 4426 -- The body is needed when generating code (full expansion), in ASIS 4427 -- mode for other tools, and in GNATprove mode (special expansion) for 4428 -- formal verification of the body itself. 4429 4430 and then (Expander_Active or ASIS_Mode or GNATprove_Mode) 4431 4432 -- No point in inlining if ABE is inevitable 4433 4434 and then not ABE_Is_Certain (N) 4435 4436 -- Or if subprogram is eliminated 4437 4438 and then not Is_Eliminated (Subp) 4439 then 4440 Pending_Instantiations.Append 4441 ((Inst_Node => N, 4442 Act_Decl => Unit_Declaration_Node (Subp), 4443 Expander_Status => Expander_Active, 4444 Current_Sem_Unit => Current_Sem_Unit, 4445 Scope_Suppress => Scope_Suppress, 4446 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 4447 Version => Ada_Version, 4448 Version_Pragma => Ada_Version_Pragma, 4449 Warnings => Save_Warnings, 4450 SPARK_Mode => SPARK_Mode, 4451 SPARK_Mode_Pragma => SPARK_Mode_Pragma)); 4452 return True; 4453 4454 -- Here if not inlined, or we ignore the inlining 4455 4456 else 4457 return False; 4458 end if; 4459 end Need_Subprogram_Instance_Body; 4460 4461 -------------------------------------- 4462 -- Analyze_Subprogram_Instantiation -- 4463 -------------------------------------- 4464 4465 procedure Analyze_Subprogram_Instantiation 4466 (N : Node_Id; 4467 K : Entity_Kind) 4468 is 4469 Loc : constant Source_Ptr := Sloc (N); 4470 Gen_Id : constant Node_Id := Name (N); 4471 4472 Anon_Id : constant Entity_Id := 4473 Make_Defining_Identifier (Sloc (Defining_Entity (N)), 4474 Chars => New_External_Name 4475 (Chars (Defining_Entity (N)), 'R')); 4476 4477 Act_Decl_Id : Entity_Id; 4478 Act_Decl : Node_Id; 4479 Act_Spec : Node_Id; 4480 Act_Tree : Node_Id; 4481 4482 Env_Installed : Boolean := False; 4483 Gen_Unit : Entity_Id; 4484 Gen_Decl : Node_Id; 4485 Pack_Id : Entity_Id; 4486 Parent_Installed : Boolean := False; 4487 Renaming_List : List_Id; 4488 4489 procedure Analyze_Instance_And_Renamings; 4490 -- The instance must be analyzed in a context that includes the mappings 4491 -- of generic parameters into actuals. We create a package declaration 4492 -- for this purpose, and a subprogram with an internal name within the 4493 -- package. The subprogram instance is simply an alias for the internal 4494 -- subprogram, declared in the current scope. 4495 4496 ------------------------------------ 4497 -- Analyze_Instance_And_Renamings -- 4498 ------------------------------------ 4499 4500 procedure Analyze_Instance_And_Renamings is 4501 Def_Ent : constant Entity_Id := Defining_Entity (N); 4502 Pack_Decl : Node_Id; 4503 4504 begin 4505 if Nkind (Parent (N)) = N_Compilation_Unit then 4506 4507 -- For the case of a compilation unit, the container package has 4508 -- the same name as the instantiation, to insure that the binder 4509 -- calls the elaboration procedure with the right name. Copy the 4510 -- entity of the instance, which may have compilation level flags 4511 -- (e.g. Is_Child_Unit) set. 4512 4513 Pack_Id := New_Copy (Def_Ent); 4514 4515 else 4516 -- Otherwise we use the name of the instantiation concatenated 4517 -- with its source position to ensure uniqueness if there are 4518 -- several instantiations with the same name. 4519 4520 Pack_Id := 4521 Make_Defining_Identifier (Loc, 4522 Chars => New_External_Name 4523 (Related_Id => Chars (Def_Ent), 4524 Suffix => "GP", 4525 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 4526 end if; 4527 4528 Pack_Decl := Make_Package_Declaration (Loc, 4529 Specification => Make_Package_Specification (Loc, 4530 Defining_Unit_Name => Pack_Id, 4531 Visible_Declarations => Renaming_List, 4532 End_Label => Empty)); 4533 4534 Set_Instance_Spec (N, Pack_Decl); 4535 Set_Is_Generic_Instance (Pack_Id); 4536 Set_Debug_Info_Needed (Pack_Id); 4537 4538 -- Case of not a compilation unit 4539 4540 if Nkind (Parent (N)) /= N_Compilation_Unit then 4541 Mark_Rewrite_Insertion (Pack_Decl); 4542 Insert_Before (N, Pack_Decl); 4543 Set_Has_Completion (Pack_Id); 4544 4545 -- Case of an instantiation that is a compilation unit 4546 4547 -- Place declaration on current node so context is complete for 4548 -- analysis (including nested instantiations), and for use in a 4549 -- context_clause (see Analyze_With_Clause). 4550 4551 else 4552 Set_Unit (Parent (N), Pack_Decl); 4553 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 4554 end if; 4555 4556 Analyze (Pack_Decl); 4557 Check_Formal_Packages (Pack_Id); 4558 Set_Is_Generic_Instance (Pack_Id, False); 4559 4560 -- Why do we clear Is_Generic_Instance??? We set it 20 lines 4561 -- above??? 4562 4563 -- Body of the enclosing package is supplied when instantiating the 4564 -- subprogram body, after semantic analysis is completed. 4565 4566 if Nkind (Parent (N)) = N_Compilation_Unit then 4567 4568 -- Remove package itself from visibility, so it does not 4569 -- conflict with subprogram. 4570 4571 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 4572 4573 -- Set name and scope of internal subprogram so that the proper 4574 -- external name will be generated. The proper scope is the scope 4575 -- of the wrapper package. We need to generate debugging info for 4576 -- the internal subprogram, so set flag accordingly. 4577 4578 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 4579 Set_Scope (Anon_Id, Scope (Pack_Id)); 4580 4581 -- Mark wrapper package as referenced, to avoid spurious warnings 4582 -- if the instantiation appears in various with_ clauses of 4583 -- subunits of the main unit. 4584 4585 Set_Referenced (Pack_Id); 4586 end if; 4587 4588 Set_Is_Generic_Instance (Anon_Id); 4589 Set_Debug_Info_Needed (Anon_Id); 4590 Act_Decl_Id := New_Copy (Anon_Id); 4591 4592 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4593 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 4594 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 4595 Set_Comes_From_Source (Act_Decl_Id, True); 4596 4597 -- The signature may involve types that are not frozen yet, but the 4598 -- subprogram will be frozen at the point the wrapper package is 4599 -- frozen, so it does not need its own freeze node. In fact, if one 4600 -- is created, it might conflict with the freezing actions from the 4601 -- wrapper package. 4602 4603 Set_Has_Delayed_Freeze (Anon_Id, False); 4604 4605 -- If the instance is a child unit, mark the Id accordingly. Mark 4606 -- the anonymous entity as well, which is the real subprogram and 4607 -- which is used when the instance appears in a context clause. 4608 -- Similarly, propagate the Is_Eliminated flag to handle properly 4609 -- nested eliminated subprograms. 4610 4611 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 4612 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 4613 New_Overloaded_Entity (Act_Decl_Id); 4614 Check_Eliminated (Act_Decl_Id); 4615 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 4616 4617 -- In compilation unit case, kill elaboration checks on the 4618 -- instantiation, since they are never needed -- the body is 4619 -- instantiated at the same point as the spec. 4620 4621 if Nkind (Parent (N)) = N_Compilation_Unit then 4622 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4623 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4624 Set_Is_Compilation_Unit (Anon_Id); 4625 4626 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 4627 end if; 4628 4629 -- The instance is not a freezing point for the new subprogram 4630 4631 Set_Is_Frozen (Act_Decl_Id, False); 4632 4633 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 4634 Valid_Operator_Definition (Act_Decl_Id); 4635 end if; 4636 4637 Set_Alias (Act_Decl_Id, Anon_Id); 4638 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 4639 Set_Has_Completion (Act_Decl_Id); 4640 Set_Related_Instance (Pack_Id, Act_Decl_Id); 4641 4642 if Nkind (Parent (N)) = N_Compilation_Unit then 4643 Set_Body_Required (Parent (N), False); 4644 end if; 4645 end Analyze_Instance_And_Renamings; 4646 4647 -- Local variables 4648 4649 Vis_Prims_List : Elist_Id := No_Elist; 4650 -- List of primitives made temporarily visible in the instantiation 4651 -- to match the visibility of the formal type 4652 4653 -- Start of processing for Analyze_Subprogram_Instantiation 4654 4655 begin 4656 Check_SPARK_Restriction ("generic is not allowed", N); 4657 4658 -- Very first thing: apply the special kludge for Text_IO processing 4659 -- in case we are instantiating one of the children of [Wide_]Text_IO. 4660 -- Of course such an instantiation is bogus (these are packages, not 4661 -- subprograms), but we get a better error message if we do this. 4662 4663 Text_IO_Kludge (Gen_Id); 4664 4665 -- Make node global for error reporting 4666 4667 Instantiation_Node := N; 4668 4669 -- For package instantiations we turn off style checks, because they 4670 -- will have been emitted in the generic. For subprogram instantiations 4671 -- we want to apply at least the check on overriding indicators so we 4672 -- do not modify the style check status. 4673 4674 -- The renaming declarations for the actuals do not come from source and 4675 -- will not generate spurious warnings. 4676 4677 Preanalyze_Actuals (N); 4678 4679 Init_Env; 4680 Env_Installed := True; 4681 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 4682 Gen_Unit := Entity (Gen_Id); 4683 4684 Generate_Reference (Gen_Unit, Gen_Id); 4685 4686 if Nkind (Gen_Id) = N_Identifier 4687 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 4688 then 4689 Error_Msg_NE 4690 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 4691 end if; 4692 4693 if Etype (Gen_Unit) = Any_Type then 4694 Restore_Env; 4695 return; 4696 end if; 4697 4698 -- Verify that it is a generic subprogram of the right kind, and that 4699 -- it does not lead to a circular instantiation. 4700 4701 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then 4702 Error_Msg_NE 4703 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); 4704 4705 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then 4706 Error_Msg_NE 4707 ("& is not the name of a generic function", Gen_Id, Gen_Unit); 4708 4709 elsif In_Open_Scopes (Gen_Unit) then 4710 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 4711 4712 else 4713 Set_Entity (Gen_Id, Gen_Unit); 4714 Set_Is_Instantiated (Gen_Unit); 4715 4716 if In_Extended_Main_Source_Unit (N) then 4717 Generate_Reference (Gen_Unit, N); 4718 end if; 4719 4720 -- If renaming, get original unit 4721 4722 if Present (Renamed_Object (Gen_Unit)) 4723 and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure 4724 or else 4725 Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function) 4726 then 4727 Gen_Unit := Renamed_Object (Gen_Unit); 4728 Set_Is_Instantiated (Gen_Unit); 4729 Generate_Reference (Gen_Unit, N); 4730 end if; 4731 4732 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 4733 Error_Msg_Node_2 := Current_Scope; 4734 Error_Msg_NE 4735 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 4736 Circularity_Detected := True; 4737 Restore_Hidden_Primitives (Vis_Prims_List); 4738 goto Leave; 4739 end if; 4740 4741 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 4742 4743 -- Initialize renamings map, for error checking 4744 4745 Generic_Renamings.Set_Last (0); 4746 Generic_Renamings_HTable.Reset; 4747 4748 Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); 4749 4750 -- Copy original generic tree, to produce text for instantiation 4751 4752 Act_Tree := 4753 Copy_Generic_Node 4754 (Original_Node (Gen_Decl), Empty, Instantiating => True); 4755 4756 -- Inherit overriding indicator from instance node 4757 4758 Act_Spec := Specification (Act_Tree); 4759 Set_Must_Override (Act_Spec, Must_Override (N)); 4760 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 4761 4762 Renaming_List := 4763 Analyze_Associations 4764 (I_Node => N, 4765 Formals => Generic_Formal_Declarations (Act_Tree), 4766 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 4767 4768 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 4769 4770 -- The subprogram itself cannot contain a nested instance, so the 4771 -- current parent is left empty. 4772 4773 Set_Instance_Env (Gen_Unit, Empty); 4774 4775 -- Build the subprogram declaration, which does not appear in the 4776 -- generic template, and give it a sloc consistent with that of the 4777 -- template. 4778 4779 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 4780 Set_Generic_Parent (Act_Spec, Gen_Unit); 4781 Act_Decl := 4782 Make_Subprogram_Declaration (Sloc (Act_Spec), 4783 Specification => Act_Spec); 4784 4785 -- The aspects have been copied previously, but they have to be 4786 -- linked explicitly to the new subprogram declaration. Explicit 4787 -- pre/postconditions on the instance are analyzed below, in a 4788 -- separate step. 4789 4790 Move_Aspects (Act_Tree, To => Act_Decl); 4791 Set_Categorization_From_Pragmas (Act_Decl); 4792 4793 if Parent_Installed then 4794 Hide_Current_Scope; 4795 end if; 4796 4797 Append (Act_Decl, Renaming_List); 4798 Analyze_Instance_And_Renamings; 4799 4800 -- If the generic is marked Import (Intrinsic), then so is the 4801 -- instance. This indicates that there is no body to instantiate. If 4802 -- generic is marked inline, so it the instance, and the anonymous 4803 -- subprogram it renames. If inlined, or else if inlining is enabled 4804 -- for the compilation, we generate the instance body even if it is 4805 -- not within the main unit. 4806 4807 if Is_Intrinsic_Subprogram (Gen_Unit) then 4808 Set_Is_Intrinsic_Subprogram (Anon_Id); 4809 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 4810 4811 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 4812 Validate_Unchecked_Conversion (N, Act_Decl_Id); 4813 end if; 4814 end if; 4815 4816 -- Inherit convention from generic unit. Intrinsic convention, as for 4817 -- an instance of unchecked conversion, is not inherited because an 4818 -- explicit Ada instance has been created. 4819 4820 if Has_Convention_Pragma (Gen_Unit) 4821 and then Convention (Gen_Unit) /= Convention_Intrinsic 4822 then 4823 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 4824 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 4825 end if; 4826 4827 Generate_Definition (Act_Decl_Id); 4828 -- Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); 4829 -- ??? needed? 4830 Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); 4831 4832 -- Inherit all inlining-related flags which apply to the generic in 4833 -- the subprogram and its declaration. 4834 4835 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 4836 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 4837 4838 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 4839 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 4840 4841 Set_Has_Pragma_Inline_Always 4842 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 4843 Set_Has_Pragma_Inline_Always 4844 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 4845 4846 if not Is_Intrinsic_Subprogram (Gen_Unit) then 4847 Check_Elab_Instantiation (N); 4848 end if; 4849 4850 if Is_Dispatching_Operation (Act_Decl_Id) 4851 and then Ada_Version >= Ada_2005 4852 then 4853 declare 4854 Formal : Entity_Id; 4855 4856 begin 4857 Formal := First_Formal (Act_Decl_Id); 4858 while Present (Formal) loop 4859 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 4860 and then Is_Controlling_Formal (Formal) 4861 and then not Can_Never_Be_Null (Formal) 4862 then 4863 Error_Msg_NE ("access parameter& is controlling,", 4864 N, Formal); 4865 Error_Msg_NE 4866 ("\corresponding parameter of & must be" 4867 & " explicitly null-excluding", N, Gen_Id); 4868 end if; 4869 4870 Next_Formal (Formal); 4871 end loop; 4872 end; 4873 end if; 4874 4875 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4876 4877 Validate_Categorization_Dependency (N, Act_Decl_Id); 4878 4879 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 4880 Inherit_Context (Gen_Decl, N); 4881 4882 Restore_Private_Views (Pack_Id, False); 4883 4884 -- If the context requires a full instantiation, mark node for 4885 -- subsequent construction of the body. 4886 4887 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 4888 Check_Forward_Instantiation (Gen_Decl); 4889 4890 -- The wrapper package is always delayed, because it does not 4891 -- constitute a freeze point, but to insure that the freeze 4892 -- node is placed properly, it is created directly when 4893 -- instantiating the body (otherwise the freeze node might 4894 -- appear to early for nested instantiations). 4895 4896 elsif Nkind (Parent (N)) = N_Compilation_Unit then 4897 4898 -- For ASIS purposes, indicate that the wrapper package has 4899 -- replaced the instantiation node. 4900 4901 Rewrite (N, Unit (Parent (N))); 4902 Set_Unit (Parent (N), N); 4903 end if; 4904 4905 elsif Nkind (Parent (N)) = N_Compilation_Unit then 4906 4907 -- Replace instance node for library-level instantiations of 4908 -- intrinsic subprograms, for ASIS use. 4909 4910 Rewrite (N, Unit (Parent (N))); 4911 Set_Unit (Parent (N), N); 4912 end if; 4913 4914 if Parent_Installed then 4915 Remove_Parent; 4916 end if; 4917 4918 Restore_Hidden_Primitives (Vis_Prims_List); 4919 Restore_Env; 4920 Env_Installed := False; 4921 Generic_Renamings.Set_Last (0); 4922 Generic_Renamings_HTable.Reset; 4923 end if; 4924 4925 <<Leave>> 4926 if Has_Aspects (N) then 4927 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4928 end if; 4929 4930 exception 4931 when Instantiation_Error => 4932 if Parent_Installed then 4933 Remove_Parent; 4934 end if; 4935 4936 if Env_Installed then 4937 Restore_Env; 4938 end if; 4939 end Analyze_Subprogram_Instantiation; 4940 4941 ------------------------- 4942 -- Get_Associated_Node -- 4943 ------------------------- 4944 4945 function Get_Associated_Node (N : Node_Id) return Node_Id is 4946 Assoc : Node_Id; 4947 4948 begin 4949 Assoc := Associated_Node (N); 4950 4951 if Nkind (Assoc) /= Nkind (N) then 4952 return Assoc; 4953 4954 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 4955 return Assoc; 4956 4957 else 4958 -- If the node is part of an inner generic, it may itself have been 4959 -- remapped into a further generic copy. Associated_Node is otherwise 4960 -- used for the entity of the node, and will be of a different node 4961 -- kind, or else N has been rewritten as a literal or function call. 4962 4963 while Present (Associated_Node (Assoc)) 4964 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 4965 loop 4966 Assoc := Associated_Node (Assoc); 4967 end loop; 4968 4969 -- Follow and additional link in case the final node was rewritten. 4970 -- This can only happen with nested generic units. 4971 4972 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 4973 and then Present (Associated_Node (Assoc)) 4974 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 4975 N_Explicit_Dereference, 4976 N_Integer_Literal, 4977 N_Real_Literal, 4978 N_String_Literal)) 4979 then 4980 Assoc := Associated_Node (Assoc); 4981 end if; 4982 4983 -- An additional special case: an unconstrained type in an object 4984 -- declaration may have been rewritten as a local subtype constrained 4985 -- by the expression in the declaration. We need to recover the 4986 -- original entity which may be global. 4987 4988 if Present (Original_Node (Assoc)) 4989 and then Nkind (Parent (N)) = N_Object_Declaration 4990 then 4991 Assoc := Original_Node (Assoc); 4992 end if; 4993 4994 return Assoc; 4995 end if; 4996 end Get_Associated_Node; 4997 4998 ------------------------------------------- 4999 -- Build_Instance_Compilation_Unit_Nodes -- 5000 ------------------------------------------- 5001 5002 procedure Build_Instance_Compilation_Unit_Nodes 5003 (N : Node_Id; 5004 Act_Body : Node_Id; 5005 Act_Decl : Node_Id) 5006 is 5007 Decl_Cunit : Node_Id; 5008 Body_Cunit : Node_Id; 5009 Citem : Node_Id; 5010 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 5011 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 5012 5013 begin 5014 -- A new compilation unit node is built for the instance declaration 5015 5016 Decl_Cunit := 5017 Make_Compilation_Unit (Sloc (N), 5018 Context_Items => Empty_List, 5019 Unit => Act_Decl, 5020 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); 5021 5022 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 5023 5024 -- The new compilation unit is linked to its body, but both share the 5025 -- same file, so we do not set Body_Required on the new unit so as not 5026 -- to create a spurious dependency on a non-existent body in the ali. 5027 -- This simplifies CodePeer unit traversal. 5028 5029 -- We use the original instantiation compilation unit as the resulting 5030 -- compilation unit of the instance, since this is the main unit. 5031 5032 Rewrite (N, Act_Body); 5033 5034 -- Propagate the aspect specifications from the package body template to 5035 -- the instantiated version of the package body. 5036 5037 if Has_Aspects (Act_Body) then 5038 Set_Aspect_Specifications 5039 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body))); 5040 end if; 5041 5042 Body_Cunit := Parent (N); 5043 5044 -- The two compilation unit nodes are linked by the Library_Unit field 5045 5046 Set_Library_Unit (Decl_Cunit, Body_Cunit); 5047 Set_Library_Unit (Body_Cunit, Decl_Cunit); 5048 5049 -- Preserve the private nature of the package if needed 5050 5051 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 5052 5053 -- If the instance is not the main unit, its context, categorization 5054 -- and elaboration entity are not relevant to the compilation. 5055 5056 if Body_Cunit /= Cunit (Main_Unit) then 5057 Make_Instance_Unit (Body_Cunit, In_Main => False); 5058 return; 5059 end if; 5060 5061 -- The context clause items on the instantiation, which are now attached 5062 -- to the body compilation unit (since the body overwrote the original 5063 -- instantiation node), semantically belong on the spec, so copy them 5064 -- there. It's harmless to leave them on the body as well. In fact one 5065 -- could argue that they belong in both places. 5066 5067 Citem := First (Context_Items (Body_Cunit)); 5068 while Present (Citem) loop 5069 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 5070 Next (Citem); 5071 end loop; 5072 5073 -- Propagate categorization flags on packages, so that they appear in 5074 -- the ali file for the spec of the unit. 5075 5076 if Ekind (New_Main) = E_Package then 5077 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 5078 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 5079 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 5080 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 5081 Set_Is_Remote_Call_Interface 5082 (Old_Main, Is_Remote_Call_Interface (New_Main)); 5083 end if; 5084 5085 -- Make entry in Units table, so that binder can generate call to 5086 -- elaboration procedure for body, if any. 5087 5088 Make_Instance_Unit (Body_Cunit, In_Main => True); 5089 Main_Unit_Entity := New_Main; 5090 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 5091 5092 -- Build elaboration entity, since the instance may certainly generate 5093 -- elaboration code requiring a flag for protection. 5094 5095 Build_Elaboration_Entity (Decl_Cunit, New_Main); 5096 end Build_Instance_Compilation_Unit_Nodes; 5097 5098 ----------------------------- 5099 -- Check_Access_Definition -- 5100 ----------------------------- 5101 5102 procedure Check_Access_Definition (N : Node_Id) is 5103 begin 5104 pragma Assert 5105 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); 5106 null; 5107 end Check_Access_Definition; 5108 5109 ----------------------------------- 5110 -- Check_Formal_Package_Instance -- 5111 ----------------------------------- 5112 5113 -- If the formal has specific parameters, they must match those of the 5114 -- actual. Both of them are instances, and the renaming declarations for 5115 -- their formal parameters appear in the same order in both. The analyzed 5116 -- formal has been analyzed in the context of the current instance. 5117 5118 procedure Check_Formal_Package_Instance 5119 (Formal_Pack : Entity_Id; 5120 Actual_Pack : Entity_Id) 5121 is 5122 E1 : Entity_Id := First_Entity (Actual_Pack); 5123 E2 : Entity_Id := First_Entity (Formal_Pack); 5124 5125 Expr1 : Node_Id; 5126 Expr2 : Node_Id; 5127 5128 procedure Check_Mismatch (B : Boolean); 5129 -- Common error routine for mismatch between the parameters of the 5130 -- actual instance and those of the formal package. 5131 5132 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 5133 -- The formal may come from a nested formal package, and the actual may 5134 -- have been constant-folded. To determine whether the two denote the 5135 -- same entity we may have to traverse several definitions to recover 5136 -- the ultimate entity that they refer to. 5137 5138 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 5139 -- Similarly, if the formal comes from a nested formal package, the 5140 -- actual may designate the formal through multiple renamings, which 5141 -- have to be followed to determine the original variable in question. 5142 5143 -------------------- 5144 -- Check_Mismatch -- 5145 -------------------- 5146 5147 procedure Check_Mismatch (B : Boolean) is 5148 Kind : constant Node_Kind := Nkind (Parent (E2)); 5149 5150 begin 5151 if Kind = N_Formal_Type_Declaration then 5152 return; 5153 5154 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 5155 N_Formal_Package_Declaration) 5156 or else Kind in N_Formal_Subprogram_Declaration 5157 then 5158 null; 5159 5160 elsif B then 5161 Error_Msg_NE 5162 ("actual for & in actual instance does not match formal", 5163 Parent (Actual_Pack), E1); 5164 end if; 5165 end Check_Mismatch; 5166 5167 -------------------------------- 5168 -- Same_Instantiated_Constant -- 5169 -------------------------------- 5170 5171 function Same_Instantiated_Constant 5172 (E1, E2 : Entity_Id) return Boolean 5173 is 5174 Ent : Entity_Id; 5175 5176 begin 5177 Ent := E2; 5178 while Present (Ent) loop 5179 if E1 = Ent then 5180 return True; 5181 5182 elsif Ekind (Ent) /= E_Constant then 5183 return False; 5184 5185 elsif Is_Entity_Name (Constant_Value (Ent)) then 5186 if Entity (Constant_Value (Ent)) = E1 then 5187 return True; 5188 else 5189 Ent := Entity (Constant_Value (Ent)); 5190 end if; 5191 5192 -- The actual may be a constant that has been folded. Recover 5193 -- original name. 5194 5195 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 5196 Ent := Entity (Original_Node (Constant_Value (Ent))); 5197 else 5198 return False; 5199 end if; 5200 end loop; 5201 5202 return False; 5203 end Same_Instantiated_Constant; 5204 5205 -------------------------------- 5206 -- Same_Instantiated_Variable -- 5207 -------------------------------- 5208 5209 function Same_Instantiated_Variable 5210 (E1, E2 : Entity_Id) return Boolean 5211 is 5212 function Original_Entity (E : Entity_Id) return Entity_Id; 5213 -- Follow chain of renamings to the ultimate ancestor 5214 5215 --------------------- 5216 -- Original_Entity -- 5217 --------------------- 5218 5219 function Original_Entity (E : Entity_Id) return Entity_Id is 5220 Orig : Entity_Id; 5221 5222 begin 5223 Orig := E; 5224 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 5225 and then Present (Renamed_Object (Orig)) 5226 and then Is_Entity_Name (Renamed_Object (Orig)) 5227 loop 5228 Orig := Entity (Renamed_Object (Orig)); 5229 end loop; 5230 5231 return Orig; 5232 end Original_Entity; 5233 5234 -- Start of processing for Same_Instantiated_Variable 5235 5236 begin 5237 return Ekind (E1) = Ekind (E2) 5238 and then Original_Entity (E1) = Original_Entity (E2); 5239 end Same_Instantiated_Variable; 5240 5241 -- Start of processing for Check_Formal_Package_Instance 5242 5243 begin 5244 while Present (E1) 5245 and then Present (E2) 5246 loop 5247 exit when Ekind (E1) = E_Package 5248 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 5249 5250 -- If the formal is the renaming of the formal package, this 5251 -- is the end of its formal part, which may occur before the 5252 -- end of the formal part in the actual in the presence of 5253 -- defaulted parameters in the formal package. 5254 5255 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 5256 and then Renamed_Entity (E2) = Scope (E2); 5257 5258 -- The analysis of the actual may generate additional internal 5259 -- entities. If the formal is defaulted, there is no corresponding 5260 -- analysis and the internal entities must be skipped, until we 5261 -- find corresponding entities again. 5262 5263 if Comes_From_Source (E2) 5264 and then not Comes_From_Source (E1) 5265 and then Chars (E1) /= Chars (E2) 5266 then 5267 while Present (E1) 5268 and then Chars (E1) /= Chars (E2) 5269 loop 5270 Next_Entity (E1); 5271 end loop; 5272 end if; 5273 5274 if No (E1) then 5275 return; 5276 5277 -- If the formal entity comes from a formal declaration, it was 5278 -- defaulted in the formal package, and no check is needed on it. 5279 5280 elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then 5281 goto Next_E; 5282 5283 -- Ditto for defaulted formal subprograms. 5284 5285 elsif Is_Overloadable (E1) 5286 and then Nkind (Unit_Declaration_Node (E2)) in 5287 N_Formal_Subprogram_Declaration 5288 then 5289 goto Next_E; 5290 5291 elsif Is_Type (E1) then 5292 5293 -- Subtypes must statically match. E1, E2 are the local entities 5294 -- that are subtypes of the actuals. Itypes generated for other 5295 -- parameters need not be checked, the check will be performed 5296 -- on the parameters themselves. 5297 5298 -- If E2 is a formal type declaration, it is a defaulted parameter 5299 -- and needs no checking. 5300 5301 if not Is_Itype (E1) 5302 and then not Is_Itype (E2) 5303 then 5304 Check_Mismatch 5305 (not Is_Type (E2) 5306 or else Etype (E1) /= Etype (E2) 5307 or else not Subtypes_Statically_Match (E1, E2)); 5308 end if; 5309 5310 elsif Ekind (E1) = E_Constant then 5311 5312 -- IN parameters must denote the same static value, or the same 5313 -- constant, or the literal null. 5314 5315 Expr1 := Expression (Parent (E1)); 5316 5317 if Ekind (E2) /= E_Constant then 5318 Check_Mismatch (True); 5319 goto Next_E; 5320 else 5321 Expr2 := Expression (Parent (E2)); 5322 end if; 5323 5324 if Is_Static_Expression (Expr1) then 5325 5326 if not Is_Static_Expression (Expr2) then 5327 Check_Mismatch (True); 5328 5329 elsif Is_Discrete_Type (Etype (E1)) then 5330 declare 5331 V1 : constant Uint := Expr_Value (Expr1); 5332 V2 : constant Uint := Expr_Value (Expr2); 5333 begin 5334 Check_Mismatch (V1 /= V2); 5335 end; 5336 5337 elsif Is_Real_Type (Etype (E1)) then 5338 declare 5339 V1 : constant Ureal := Expr_Value_R (Expr1); 5340 V2 : constant Ureal := Expr_Value_R (Expr2); 5341 begin 5342 Check_Mismatch (V1 /= V2); 5343 end; 5344 5345 elsif Is_String_Type (Etype (E1)) 5346 and then Nkind (Expr1) = N_String_Literal 5347 then 5348 if Nkind (Expr2) /= N_String_Literal then 5349 Check_Mismatch (True); 5350 else 5351 Check_Mismatch 5352 (not String_Equal (Strval (Expr1), Strval (Expr2))); 5353 end if; 5354 end if; 5355 5356 elsif Is_Entity_Name (Expr1) then 5357 if Is_Entity_Name (Expr2) then 5358 if Entity (Expr1) = Entity (Expr2) then 5359 null; 5360 else 5361 Check_Mismatch 5362 (not Same_Instantiated_Constant 5363 (Entity (Expr1), Entity (Expr2))); 5364 end if; 5365 else 5366 Check_Mismatch (True); 5367 end if; 5368 5369 elsif Is_Entity_Name (Original_Node (Expr1)) 5370 and then Is_Entity_Name (Expr2) 5371 and then 5372 Same_Instantiated_Constant 5373 (Entity (Original_Node (Expr1)), Entity (Expr2)) 5374 then 5375 null; 5376 5377 elsif Nkind (Expr1) = N_Null then 5378 Check_Mismatch (Nkind (Expr1) /= N_Null); 5379 5380 else 5381 Check_Mismatch (True); 5382 end if; 5383 5384 elsif Ekind (E1) = E_Variable then 5385 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 5386 5387 elsif Ekind (E1) = E_Package then 5388 Check_Mismatch 5389 (Ekind (E1) /= Ekind (E2) 5390 or else Renamed_Object (E1) /= Renamed_Object (E2)); 5391 5392 elsif Is_Overloadable (E1) then 5393 5394 -- Verify that the actual subprograms match. Note that actuals 5395 -- that are attributes are rewritten as subprograms. If the 5396 -- subprogram in the formal package is defaulted, no check is 5397 -- needed. Note that this can only happen in Ada 2005 when the 5398 -- formal package can be partially parameterized. 5399 5400 if Nkind (Unit_Declaration_Node (E1)) = 5401 N_Subprogram_Renaming_Declaration 5402 and then From_Default (Unit_Declaration_Node (E1)) 5403 then 5404 null; 5405 5406 -- If the formal package has an "others" box association that 5407 -- covers this formal, there is no need for a check either. 5408 5409 elsif Nkind (Unit_Declaration_Node (E2)) in 5410 N_Formal_Subprogram_Declaration 5411 and then Box_Present (Unit_Declaration_Node (E2)) 5412 then 5413 null; 5414 5415 -- No check needed if subprogram is a defaulted null procedure 5416 5417 elsif No (Alias (E2)) 5418 and then Ekind (E2) = E_Procedure 5419 and then 5420 Null_Present (Specification (Unit_Declaration_Node (E2))) 5421 then 5422 null; 5423 5424 -- Otherwise the actual in the formal and the actual in the 5425 -- instantiation of the formal must match, up to renamings. 5426 5427 else 5428 Check_Mismatch 5429 (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); 5430 end if; 5431 5432 else 5433 raise Program_Error; 5434 end if; 5435 5436 <<Next_E>> 5437 Next_Entity (E1); 5438 Next_Entity (E2); 5439 end loop; 5440 end Check_Formal_Package_Instance; 5441 5442 --------------------------- 5443 -- Check_Formal_Packages -- 5444 --------------------------- 5445 5446 procedure Check_Formal_Packages (P_Id : Entity_Id) is 5447 E : Entity_Id; 5448 Formal_P : Entity_Id; 5449 5450 begin 5451 -- Iterate through the declarations in the instance, looking for package 5452 -- renaming declarations that denote instances of formal packages. Stop 5453 -- when we find the renaming of the current package itself. The 5454 -- declaration for a formal package without a box is followed by an 5455 -- internal entity that repeats the instantiation. 5456 5457 E := First_Entity (P_Id); 5458 while Present (E) loop 5459 if Ekind (E) = E_Package then 5460 if Renamed_Object (E) = P_Id then 5461 exit; 5462 5463 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 5464 null; 5465 5466 elsif not Box_Present (Parent (Associated_Formal_Package (E))) then 5467 Formal_P := Next_Entity (E); 5468 Check_Formal_Package_Instance (Formal_P, E); 5469 5470 -- After checking, remove the internal validating package. It 5471 -- is only needed for semantic checks, and as it may contain 5472 -- generic formal declarations it should not reach gigi. 5473 5474 Remove (Unit_Declaration_Node (Formal_P)); 5475 end if; 5476 end if; 5477 5478 Next_Entity (E); 5479 end loop; 5480 end Check_Formal_Packages; 5481 5482 --------------------------------- 5483 -- Check_Forward_Instantiation -- 5484 --------------------------------- 5485 5486 procedure Check_Forward_Instantiation (Decl : Node_Id) is 5487 S : Entity_Id; 5488 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 5489 5490 begin 5491 -- The instantiation appears before the generic body if we are in the 5492 -- scope of the unit containing the generic, either in its spec or in 5493 -- the package body, and before the generic body. 5494 5495 if Ekind (Gen_Comp) = E_Package_Body then 5496 Gen_Comp := Spec_Entity (Gen_Comp); 5497 end if; 5498 5499 if In_Open_Scopes (Gen_Comp) 5500 and then No (Corresponding_Body (Decl)) 5501 then 5502 S := Current_Scope; 5503 5504 while Present (S) 5505 and then not Is_Compilation_Unit (S) 5506 and then not Is_Child_Unit (S) 5507 loop 5508 if Ekind (S) = E_Package then 5509 Set_Has_Forward_Instantiation (S); 5510 end if; 5511 5512 S := Scope (S); 5513 end loop; 5514 end if; 5515 end Check_Forward_Instantiation; 5516 5517 --------------------------- 5518 -- Check_Generic_Actuals -- 5519 --------------------------- 5520 5521 -- The visibility of the actuals may be different between the point of 5522 -- generic instantiation and the instantiation of the body. 5523 5524 procedure Check_Generic_Actuals 5525 (Instance : Entity_Id; 5526 Is_Formal_Box : Boolean) 5527 is 5528 E : Entity_Id; 5529 Astype : Entity_Id; 5530 5531 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 5532 -- For a formal that is an array type, the component type is often a 5533 -- previous formal in the same unit. The privacy status of the component 5534 -- type will have been examined earlier in the traversal of the 5535 -- corresponding actuals, and this status should not be modified for 5536 -- the array (sub)type itself. However, if the base type of the array 5537 -- (sub)type is private, its full view must be restored in the body to 5538 -- be consistent with subsequent index subtypes, etc. 5539 -- 5540 -- To detect this case we have to rescan the list of formals, which is 5541 -- usually short enough to ignore the resulting inefficiency. 5542 5543 ----------------------------- 5544 -- Denotes_Previous_Actual -- 5545 ----------------------------- 5546 5547 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 5548 Prev : Entity_Id; 5549 5550 begin 5551 Prev := First_Entity (Instance); 5552 while Present (Prev) loop 5553 if Is_Type (Prev) 5554 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 5555 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 5556 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 5557 then 5558 return True; 5559 5560 elsif Prev = E then 5561 return False; 5562 5563 else 5564 Next_Entity (Prev); 5565 end if; 5566 end loop; 5567 5568 return False; 5569 end Denotes_Previous_Actual; 5570 5571 -- Start of processing for Check_Generic_Actuals 5572 5573 begin 5574 E := First_Entity (Instance); 5575 while Present (E) loop 5576 if Is_Type (E) 5577 and then Nkind (Parent (E)) = N_Subtype_Declaration 5578 and then Scope (Etype (E)) /= Instance 5579 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 5580 then 5581 if Is_Array_Type (E) 5582 and then not Is_Private_Type (Etype (E)) 5583 and then Denotes_Previous_Actual (Component_Type (E)) 5584 then 5585 null; 5586 else 5587 Check_Private_View (Subtype_Indication (Parent (E))); 5588 end if; 5589 5590 Set_Is_Generic_Actual_Type (E, True); 5591 Set_Is_Hidden (E, False); 5592 Set_Is_Potentially_Use_Visible (E, 5593 In_Use (Instance)); 5594 5595 -- We constructed the generic actual type as a subtype of the 5596 -- supplied type. This means that it normally would not inherit 5597 -- subtype specific attributes of the actual, which is wrong for 5598 -- the generic case. 5599 5600 Astype := Ancestor_Subtype (E); 5601 5602 if No (Astype) then 5603 5604 -- This can happen when E is an itype that is the full view of 5605 -- a private type completed, e.g. with a constrained array. In 5606 -- that case, use the first subtype, which will carry size 5607 -- information. The base type itself is unconstrained and will 5608 -- not carry it. 5609 5610 Astype := First_Subtype (E); 5611 end if; 5612 5613 Set_Size_Info (E, (Astype)); 5614 Set_RM_Size (E, RM_Size (Astype)); 5615 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 5616 5617 if Is_Discrete_Or_Fixed_Point_Type (E) then 5618 Set_RM_Size (E, RM_Size (Astype)); 5619 5620 -- In nested instances, the base type of an access actual may 5621 -- itself be private, and need to be exchanged. 5622 5623 elsif Is_Access_Type (E) 5624 and then Is_Private_Type (Etype (E)) 5625 then 5626 Check_Private_View 5627 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 5628 end if; 5629 5630 elsif Ekind (E) = E_Package then 5631 5632 -- If this is the renaming for the current instance, we're done. 5633 -- Otherwise it is a formal package. If the corresponding formal 5634 -- was declared with a box, the (instantiations of the) generic 5635 -- formal part are also visible. Otherwise, ignore the entity 5636 -- created to validate the actuals. 5637 5638 if Renamed_Object (E) = Instance then 5639 exit; 5640 5641 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 5642 null; 5643 5644 -- The visibility of a formal of an enclosing generic is already 5645 -- correct. 5646 5647 elsif Denotes_Formal_Package (E) then 5648 null; 5649 5650 elsif Present (Associated_Formal_Package (E)) 5651 and then not Is_Generic_Formal (E) 5652 then 5653 if Box_Present (Parent (Associated_Formal_Package (E))) then 5654 Check_Generic_Actuals (Renamed_Object (E), True); 5655 5656 else 5657 Check_Generic_Actuals (Renamed_Object (E), False); 5658 end if; 5659 5660 Set_Is_Hidden (E, False); 5661 end if; 5662 5663 -- If this is a subprogram instance (in a wrapper package) the 5664 -- actual is fully visible. 5665 5666 elsif Is_Wrapper_Package (Instance) then 5667 Set_Is_Hidden (E, False); 5668 5669 -- If the formal package is declared with a box, or if the formal 5670 -- parameter is defaulted, it is visible in the body. 5671 5672 elsif Is_Formal_Box 5673 or else Is_Visible_Formal (E) 5674 then 5675 Set_Is_Hidden (E, False); 5676 end if; 5677 5678 if Ekind (E) = E_Constant then 5679 5680 -- If the type of the actual is a private type declared in the 5681 -- enclosing scope of the generic unit, the body of the generic 5682 -- sees the full view of the type (because it has to appear in 5683 -- the corresponding package body). If the type is private now, 5684 -- exchange views to restore the proper visiblity in the instance. 5685 5686 declare 5687 Typ : constant Entity_Id := Base_Type (Etype (E)); 5688 -- The type of the actual 5689 5690 Gen_Id : Entity_Id; 5691 -- The generic unit 5692 5693 Parent_Scope : Entity_Id; 5694 -- The enclosing scope of the generic unit 5695 5696 begin 5697 if Is_Wrapper_Package (Instance) then 5698 Gen_Id := 5699 Generic_Parent 5700 (Specification 5701 (Unit_Declaration_Node 5702 (Related_Instance (Instance)))); 5703 else 5704 Gen_Id := 5705 Generic_Parent (Package_Specification (Instance)); 5706 end if; 5707 5708 Parent_Scope := Scope (Gen_Id); 5709 5710 -- The exchange is only needed if the generic is defined 5711 -- within a package which is not a common ancestor of the 5712 -- scope of the instance, and is not already in scope. 5713 5714 if Is_Private_Type (Typ) 5715 and then Scope (Typ) = Parent_Scope 5716 and then Scope (Instance) /= Parent_Scope 5717 and then Ekind (Parent_Scope) = E_Package 5718 and then not Is_Child_Unit (Gen_Id) 5719 then 5720 Switch_View (Typ); 5721 5722 -- If the type of the entity is a subtype, it may also have 5723 -- to be made visible, together with the base type of its 5724 -- full view, after exchange. 5725 5726 if Is_Private_Type (Etype (E)) then 5727 Switch_View (Etype (E)); 5728 Switch_View (Base_Type (Etype (E))); 5729 end if; 5730 end if; 5731 end; 5732 end if; 5733 5734 Next_Entity (E); 5735 end loop; 5736 end Check_Generic_Actuals; 5737 5738 ------------------------------ 5739 -- Check_Generic_Child_Unit -- 5740 ------------------------------ 5741 5742 procedure Check_Generic_Child_Unit 5743 (Gen_Id : Node_Id; 5744 Parent_Installed : in out Boolean) 5745 is 5746 Loc : constant Source_Ptr := Sloc (Gen_Id); 5747 Gen_Par : Entity_Id := Empty; 5748 E : Entity_Id; 5749 Inst_Par : Entity_Id; 5750 S : Node_Id; 5751 5752 function Find_Generic_Child 5753 (Scop : Entity_Id; 5754 Id : Node_Id) return Entity_Id; 5755 -- Search generic parent for possible child unit with the given name 5756 5757 function In_Enclosing_Instance return Boolean; 5758 -- Within an instance of the parent, the child unit may be denoted by 5759 -- a simple name, or an abbreviated expanded name. Examine enclosing 5760 -- scopes to locate a possible parent instantiation. 5761 5762 ------------------------ 5763 -- Find_Generic_Child -- 5764 ------------------------ 5765 5766 function Find_Generic_Child 5767 (Scop : Entity_Id; 5768 Id : Node_Id) return Entity_Id 5769 is 5770 E : Entity_Id; 5771 5772 begin 5773 -- If entity of name is already set, instance has already been 5774 -- resolved, e.g. in an enclosing instantiation. 5775 5776 if Present (Entity (Id)) then 5777 if Scope (Entity (Id)) = Scop then 5778 return Entity (Id); 5779 else 5780 return Empty; 5781 end if; 5782 5783 else 5784 E := First_Entity (Scop); 5785 while Present (E) loop 5786 if Chars (E) = Chars (Id) 5787 and then Is_Child_Unit (E) 5788 then 5789 if Is_Child_Unit (E) 5790 and then not Is_Visible_Lib_Unit (E) 5791 then 5792 Error_Msg_NE 5793 ("generic child unit& is not visible", Gen_Id, E); 5794 end if; 5795 5796 Set_Entity (Id, E); 5797 return E; 5798 end if; 5799 5800 Next_Entity (E); 5801 end loop; 5802 5803 return Empty; 5804 end if; 5805 end Find_Generic_Child; 5806 5807 --------------------------- 5808 -- In_Enclosing_Instance -- 5809 --------------------------- 5810 5811 function In_Enclosing_Instance return Boolean is 5812 Enclosing_Instance : Node_Id; 5813 Instance_Decl : Node_Id; 5814 5815 begin 5816 -- We do not inline any call that contains instantiations, except 5817 -- for instantiations of Unchecked_Conversion, so if we are within 5818 -- an inlined body the current instance does not require parents. 5819 5820 if In_Inlined_Body then 5821 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 5822 return False; 5823 end if; 5824 5825 -- Loop to check enclosing scopes 5826 5827 Enclosing_Instance := Current_Scope; 5828 while Present (Enclosing_Instance) loop 5829 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 5830 5831 if Ekind (Enclosing_Instance) = E_Package 5832 and then Is_Generic_Instance (Enclosing_Instance) 5833 and then Present 5834 (Generic_Parent (Specification (Instance_Decl))) 5835 then 5836 -- Check whether the generic we are looking for is a child of 5837 -- this instance. 5838 5839 E := Find_Generic_Child 5840 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 5841 exit when Present (E); 5842 5843 else 5844 E := Empty; 5845 end if; 5846 5847 Enclosing_Instance := Scope (Enclosing_Instance); 5848 end loop; 5849 5850 if No (E) then 5851 5852 -- Not a child unit 5853 5854 Analyze (Gen_Id); 5855 return False; 5856 5857 else 5858 Rewrite (Gen_Id, 5859 Make_Expanded_Name (Loc, 5860 Chars => Chars (E), 5861 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 5862 Selector_Name => New_Occurrence_Of (E, Loc))); 5863 5864 Set_Entity (Gen_Id, E); 5865 Set_Etype (Gen_Id, Etype (E)); 5866 Parent_Installed := False; -- Already in scope. 5867 return True; 5868 end if; 5869 end In_Enclosing_Instance; 5870 5871 -- Start of processing for Check_Generic_Child_Unit 5872 5873 begin 5874 -- If the name of the generic is given by a selected component, it may 5875 -- be the name of a generic child unit, and the prefix is the name of an 5876 -- instance of the parent, in which case the child unit must be visible. 5877 -- If this instance is not in scope, it must be placed there and removed 5878 -- after instantiation, because what is being instantiated is not the 5879 -- original child, but the corresponding child present in the instance 5880 -- of the parent. 5881 5882 -- If the child is instantiated within the parent, it can be given by 5883 -- a simple name. In this case the instance is already in scope, but 5884 -- the child generic must be recovered from the generic parent as well. 5885 5886 if Nkind (Gen_Id) = N_Selected_Component then 5887 S := Selector_Name (Gen_Id); 5888 Analyze (Prefix (Gen_Id)); 5889 Inst_Par := Entity (Prefix (Gen_Id)); 5890 5891 if Ekind (Inst_Par) = E_Package 5892 and then Present (Renamed_Object (Inst_Par)) 5893 then 5894 Inst_Par := Renamed_Object (Inst_Par); 5895 end if; 5896 5897 if Ekind (Inst_Par) = E_Package then 5898 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 5899 Gen_Par := Generic_Parent (Parent (Inst_Par)); 5900 5901 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 5902 and then 5903 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 5904 then 5905 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 5906 end if; 5907 5908 elsif Ekind (Inst_Par) = E_Generic_Package 5909 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 5910 then 5911 -- A formal package may be a real child package, and not the 5912 -- implicit instance within a parent. In this case the child is 5913 -- not visible and has to be retrieved explicitly as well. 5914 5915 Gen_Par := Inst_Par; 5916 end if; 5917 5918 if Present (Gen_Par) then 5919 5920 -- The prefix denotes an instantiation. The entity itself may be a 5921 -- nested generic, or a child unit. 5922 5923 E := Find_Generic_Child (Gen_Par, S); 5924 5925 if Present (E) then 5926 Change_Selected_Component_To_Expanded_Name (Gen_Id); 5927 Set_Entity (Gen_Id, E); 5928 Set_Etype (Gen_Id, Etype (E)); 5929 Set_Entity (S, E); 5930 Set_Etype (S, Etype (E)); 5931 5932 -- Indicate that this is a reference to the parent 5933 5934 if In_Extended_Main_Source_Unit (Gen_Id) then 5935 Set_Is_Instantiated (Inst_Par); 5936 end if; 5937 5938 -- A common mistake is to replicate the naming scheme of a 5939 -- hierarchy by instantiating a generic child directly, rather 5940 -- than the implicit child in a parent instance: 5941 5942 -- generic .. package Gpar is .. 5943 -- generic .. package Gpar.Child is .. 5944 -- package Par is new Gpar (); 5945 5946 -- with Gpar.Child; 5947 -- package Par.Child is new Gpar.Child (); 5948 -- rather than Par.Child 5949 5950 -- In this case the instantiation is within Par, which is an 5951 -- instance, but Gpar does not denote Par because we are not IN 5952 -- the instance of Gpar, so this is illegal. The test below 5953 -- recognizes this particular case. 5954 5955 if Is_Child_Unit (E) 5956 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 5957 and then (not In_Instance 5958 or else Nkind (Parent (Parent (Gen_Id))) = 5959 N_Compilation_Unit) 5960 then 5961 Error_Msg_N 5962 ("prefix of generic child unit must be instance of parent", 5963 Gen_Id); 5964 end if; 5965 5966 if not In_Open_Scopes (Inst_Par) 5967 and then Nkind (Parent (Gen_Id)) not in 5968 N_Generic_Renaming_Declaration 5969 then 5970 Install_Parent (Inst_Par); 5971 Parent_Installed := True; 5972 5973 elsif In_Open_Scopes (Inst_Par) then 5974 5975 -- If the parent is already installed, install the actuals 5976 -- for its formal packages. This is necessary when the child 5977 -- instance is a child of the parent instance: in this case, 5978 -- the parent is placed on the scope stack but the formal 5979 -- packages are not made visible. 5980 5981 Install_Formal_Packages (Inst_Par); 5982 end if; 5983 5984 else 5985 -- If the generic parent does not contain an entity that 5986 -- corresponds to the selector, the instance doesn't either. 5987 -- Analyzing the node will yield the appropriate error message. 5988 -- If the entity is not a child unit, then it is an inner 5989 -- generic in the parent. 5990 5991 Analyze (Gen_Id); 5992 end if; 5993 5994 else 5995 Analyze (Gen_Id); 5996 5997 if Is_Child_Unit (Entity (Gen_Id)) 5998 and then 5999 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 6000 and then not In_Open_Scopes (Inst_Par) 6001 then 6002 Install_Parent (Inst_Par); 6003 Parent_Installed := True; 6004 6005 -- The generic unit may be the renaming of the implicit child 6006 -- present in an instance. In that case the parent instance is 6007 -- obtained from the name of the renamed entity. 6008 6009 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 6010 and then Present (Renamed_Entity (Entity (Gen_Id))) 6011 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 6012 then 6013 declare 6014 Renamed_Package : constant Node_Id := 6015 Name (Parent (Entity (Gen_Id))); 6016 begin 6017 if Nkind (Renamed_Package) = N_Expanded_Name then 6018 Inst_Par := Entity (Prefix (Renamed_Package)); 6019 Install_Parent (Inst_Par); 6020 Parent_Installed := True; 6021 end if; 6022 end; 6023 end if; 6024 end if; 6025 6026 elsif Nkind (Gen_Id) = N_Expanded_Name then 6027 6028 -- Entity already present, analyze prefix, whose meaning may be 6029 -- an instance in the current context. If it is an instance of 6030 -- a relative within another, the proper parent may still have 6031 -- to be installed, if they are not of the same generation. 6032 6033 Analyze (Prefix (Gen_Id)); 6034 6035 -- In the unlikely case that a local declaration hides the name 6036 -- of the parent package, locate it on the homonym chain. If the 6037 -- context is an instance of the parent, the renaming entity is 6038 -- flagged as such. 6039 6040 Inst_Par := Entity (Prefix (Gen_Id)); 6041 while Present (Inst_Par) 6042 and then not Is_Package_Or_Generic_Package (Inst_Par) 6043 loop 6044 Inst_Par := Homonym (Inst_Par); 6045 end loop; 6046 6047 pragma Assert (Present (Inst_Par)); 6048 Set_Entity (Prefix (Gen_Id), Inst_Par); 6049 6050 if In_Enclosing_Instance then 6051 null; 6052 6053 elsif Present (Entity (Gen_Id)) 6054 and then Is_Child_Unit (Entity (Gen_Id)) 6055 and then not In_Open_Scopes (Inst_Par) 6056 then 6057 Install_Parent (Inst_Par); 6058 Parent_Installed := True; 6059 end if; 6060 6061 elsif In_Enclosing_Instance then 6062 6063 -- The child unit is found in some enclosing scope 6064 6065 null; 6066 6067 else 6068 Analyze (Gen_Id); 6069 6070 -- If this is the renaming of the implicit child in a parent 6071 -- instance, recover the parent name and install it. 6072 6073 if Is_Entity_Name (Gen_Id) then 6074 E := Entity (Gen_Id); 6075 6076 if Is_Generic_Unit (E) 6077 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 6078 and then Is_Child_Unit (Renamed_Object (E)) 6079 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 6080 and then Nkind (Name (Parent (E))) = N_Expanded_Name 6081 then 6082 Rewrite (Gen_Id, 6083 New_Copy_Tree (Name (Parent (E)))); 6084 Inst_Par := Entity (Prefix (Gen_Id)); 6085 6086 if not In_Open_Scopes (Inst_Par) then 6087 Install_Parent (Inst_Par); 6088 Parent_Installed := True; 6089 end if; 6090 6091 -- If it is a child unit of a non-generic parent, it may be 6092 -- use-visible and given by a direct name. Install parent as 6093 -- for other cases. 6094 6095 elsif Is_Generic_Unit (E) 6096 and then Is_Child_Unit (E) 6097 and then 6098 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 6099 and then not Is_Generic_Unit (Scope (E)) 6100 then 6101 if not In_Open_Scopes (Scope (E)) then 6102 Install_Parent (Scope (E)); 6103 Parent_Installed := True; 6104 end if; 6105 end if; 6106 end if; 6107 end if; 6108 end Check_Generic_Child_Unit; 6109 6110 ----------------------------- 6111 -- Check_Hidden_Child_Unit -- 6112 ----------------------------- 6113 6114 procedure Check_Hidden_Child_Unit 6115 (N : Node_Id; 6116 Gen_Unit : Entity_Id; 6117 Act_Decl_Id : Entity_Id) 6118 is 6119 Gen_Id : constant Node_Id := Name (N); 6120 6121 begin 6122 if Is_Child_Unit (Gen_Unit) 6123 and then Is_Child_Unit (Act_Decl_Id) 6124 and then Nkind (Gen_Id) = N_Expanded_Name 6125 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 6126 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 6127 then 6128 Error_Msg_Node_2 := Scope (Act_Decl_Id); 6129 Error_Msg_NE 6130 ("generic unit & is implicitly declared in &", 6131 Defining_Unit_Name (N), Gen_Unit); 6132 Error_Msg_N ("\instance must have different name", 6133 Defining_Unit_Name (N)); 6134 end if; 6135 end Check_Hidden_Child_Unit; 6136 6137 ------------------------ 6138 -- Check_Private_View -- 6139 ------------------------ 6140 6141 procedure Check_Private_View (N : Node_Id) is 6142 T : constant Entity_Id := Etype (N); 6143 BT : Entity_Id; 6144 6145 begin 6146 -- Exchange views if the type was not private in the generic but is 6147 -- private at the point of instantiation. Do not exchange views if 6148 -- the scope of the type is in scope. This can happen if both generic 6149 -- and instance are sibling units, or if type is defined in a parent. 6150 -- In this case the visibility of the type will be correct for all 6151 -- semantic checks. 6152 6153 if Present (T) then 6154 BT := Base_Type (T); 6155 6156 if Is_Private_Type (T) 6157 and then not Has_Private_View (N) 6158 and then Present (Full_View (T)) 6159 and then not In_Open_Scopes (Scope (T)) 6160 then 6161 -- In the generic, the full type was visible. Save the private 6162 -- entity, for subsequent exchange. 6163 6164 Switch_View (T); 6165 6166 elsif Has_Private_View (N) 6167 and then not Is_Private_Type (T) 6168 and then not Has_Been_Exchanged (T) 6169 and then Etype (Get_Associated_Node (N)) /= T 6170 then 6171 -- Only the private declaration was visible in the generic. If 6172 -- the type appears in a subtype declaration, the subtype in the 6173 -- instance must have a view compatible with that of its parent, 6174 -- which must be exchanged (see corresponding code in Restore_ 6175 -- Private_Views). Otherwise, if the type is defined in a parent 6176 -- unit, leave full visibility within instance, which is safe. 6177 6178 if In_Open_Scopes (Scope (Base_Type (T))) 6179 and then not Is_Private_Type (Base_Type (T)) 6180 and then Comes_From_Source (Base_Type (T)) 6181 then 6182 null; 6183 6184 elsif Nkind (Parent (N)) = N_Subtype_Declaration 6185 or else not In_Private_Part (Scope (Base_Type (T))) 6186 then 6187 Prepend_Elmt (T, Exchanged_Views); 6188 Exchange_Declarations (Etype (Get_Associated_Node (N))); 6189 end if; 6190 6191 -- For composite types with inconsistent representation exchange 6192 -- component types accordingly. 6193 6194 elsif Is_Access_Type (T) 6195 and then Is_Private_Type (Designated_Type (T)) 6196 and then not Has_Private_View (N) 6197 and then Present (Full_View (Designated_Type (T))) 6198 then 6199 Switch_View (Designated_Type (T)); 6200 6201 elsif Is_Array_Type (T) then 6202 if Is_Private_Type (Component_Type (T)) 6203 and then not Has_Private_View (N) 6204 and then Present (Full_View (Component_Type (T))) 6205 then 6206 Switch_View (Component_Type (T)); 6207 end if; 6208 6209 -- The normal exchange mechanism relies on the setting of a 6210 -- flag on the reference in the generic. However, an additional 6211 -- mechanism is needed for types that are not explicitly 6212 -- mentioned in the generic, but may be needed in expanded code 6213 -- in the instance. This includes component types of arrays and 6214 -- designated types of access types. This processing must also 6215 -- include the index types of arrays which we take care of here. 6216 6217 declare 6218 Indx : Node_Id; 6219 Typ : Entity_Id; 6220 6221 begin 6222 Indx := First_Index (T); 6223 while Present (Indx) loop 6224 Typ := Base_Type (Etype (Indx)); 6225 6226 if Is_Private_Type (Typ) 6227 and then Present (Full_View (Typ)) 6228 then 6229 Switch_View (Typ); 6230 end if; 6231 6232 Next_Index (Indx); 6233 end loop; 6234 end; 6235 6236 elsif Is_Private_Type (T) 6237 and then Present (Full_View (T)) 6238 and then Is_Array_Type (Full_View (T)) 6239 and then Is_Private_Type (Component_Type (Full_View (T))) 6240 then 6241 Switch_View (T); 6242 6243 -- Finally, a non-private subtype may have a private base type, which 6244 -- must be exchanged for consistency. This can happen when a package 6245 -- body is instantiated, when the scope stack is empty but in fact 6246 -- the subtype and the base type are declared in an enclosing scope. 6247 6248 -- Note that in this case we introduce an inconsistency in the view 6249 -- set, because we switch the base type BT, but there could be some 6250 -- private dependent subtypes of BT which remain unswitched. Such 6251 -- subtypes might need to be switched at a later point (see specific 6252 -- provision for that case in Switch_View). 6253 6254 elsif not Is_Private_Type (T) 6255 and then not Has_Private_View (N) 6256 and then Is_Private_Type (BT) 6257 and then Present (Full_View (BT)) 6258 and then not Is_Generic_Type (BT) 6259 and then not In_Open_Scopes (BT) 6260 then 6261 Prepend_Elmt (Full_View (BT), Exchanged_Views); 6262 Exchange_Declarations (BT); 6263 end if; 6264 end if; 6265 end Check_Private_View; 6266 6267 ----------------------------- 6268 -- Check_Hidden_Primitives -- 6269 ----------------------------- 6270 6271 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 6272 Actual : Node_Id; 6273 Gen_T : Entity_Id; 6274 Result : Elist_Id := No_Elist; 6275 6276 begin 6277 if No (Assoc_List) then 6278 return No_Elist; 6279 end if; 6280 6281 -- Traverse the list of associations between formals and actuals 6282 -- searching for renamings of tagged types 6283 6284 Actual := First (Assoc_List); 6285 while Present (Actual) loop 6286 if Nkind (Actual) = N_Subtype_Declaration then 6287 Gen_T := Generic_Parent_Type (Actual); 6288 6289 if Present (Gen_T) 6290 and then Is_Tagged_Type (Gen_T) 6291 then 6292 -- Traverse the list of primitives of the actual types 6293 -- searching for hidden primitives that are visible in the 6294 -- corresponding generic formal; leave them visible and 6295 -- append them to Result to restore their decoration later. 6296 6297 Install_Hidden_Primitives 6298 (Prims_List => Result, 6299 Gen_T => Gen_T, 6300 Act_T => Entity (Subtype_Indication (Actual))); 6301 end if; 6302 end if; 6303 6304 Next (Actual); 6305 end loop; 6306 6307 return Result; 6308 end Check_Hidden_Primitives; 6309 6310 -------------------------- 6311 -- Contains_Instance_Of -- 6312 -------------------------- 6313 6314 function Contains_Instance_Of 6315 (Inner : Entity_Id; 6316 Outer : Entity_Id; 6317 N : Node_Id) return Boolean 6318 is 6319 Elmt : Elmt_Id; 6320 Scop : Entity_Id; 6321 6322 begin 6323 Scop := Outer; 6324 6325 -- Verify that there are no circular instantiations. We check whether 6326 -- the unit contains an instance of the current scope or some enclosing 6327 -- scope (in case one of the instances appears in a subunit). Longer 6328 -- circularities involving subunits might seem too pathological to 6329 -- consider, but they were not too pathological for the authors of 6330 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 6331 -- enclosing generic scopes as containing an instance. 6332 6333 loop 6334 -- Within a generic subprogram body, the scope is not generic, to 6335 -- allow for recursive subprograms. Use the declaration to determine 6336 -- whether this is a generic unit. 6337 6338 if Ekind (Scop) = E_Generic_Package 6339 or else (Is_Subprogram (Scop) 6340 and then Nkind (Unit_Declaration_Node (Scop)) = 6341 N_Generic_Subprogram_Declaration) 6342 then 6343 Elmt := First_Elmt (Inner_Instances (Inner)); 6344 6345 while Present (Elmt) loop 6346 if Node (Elmt) = Scop then 6347 Error_Msg_Node_2 := Inner; 6348 Error_Msg_NE 6349 ("circular Instantiation: & instantiated within &!", 6350 N, Scop); 6351 return True; 6352 6353 elsif Node (Elmt) = Inner then 6354 return True; 6355 6356 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 6357 Error_Msg_Node_2 := Inner; 6358 Error_Msg_NE 6359 ("circular Instantiation: & instantiated within &!", 6360 N, Node (Elmt)); 6361 return True; 6362 end if; 6363 6364 Next_Elmt (Elmt); 6365 end loop; 6366 6367 -- Indicate that Inner is being instantiated within Scop 6368 6369 Append_Elmt (Inner, Inner_Instances (Scop)); 6370 end if; 6371 6372 if Scop = Standard_Standard then 6373 exit; 6374 else 6375 Scop := Scope (Scop); 6376 end if; 6377 end loop; 6378 6379 return False; 6380 end Contains_Instance_Of; 6381 6382 ----------------------- 6383 -- Copy_Generic_Node -- 6384 ----------------------- 6385 6386 function Copy_Generic_Node 6387 (N : Node_Id; 6388 Parent_Id : Node_Id; 6389 Instantiating : Boolean) return Node_Id 6390 is 6391 Ent : Entity_Id; 6392 New_N : Node_Id; 6393 6394 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 6395 -- Check the given value of one of the Fields referenced by the current 6396 -- node to determine whether to copy it recursively. The field may hold 6397 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, 6398 -- Char) in which case it need not be copied. 6399 6400 procedure Copy_Descendants; 6401 -- Common utility for various nodes 6402 6403 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 6404 -- Make copy of element list 6405 6406 function Copy_Generic_List 6407 (L : List_Id; 6408 Parent_Id : Node_Id) return List_Id; 6409 -- Apply Copy_Node recursively to the members of a node list 6410 6411 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 6412 -- True if an identifier is part of the defining program unit name of 6413 -- a child unit. The entity of such an identifier must be kept (for 6414 -- ASIS use) even though as the name of an enclosing generic it would 6415 -- otherwise not be preserved in the generic tree. 6416 6417 ---------------------- 6418 -- Copy_Descendants -- 6419 ---------------------- 6420 6421 procedure Copy_Descendants is 6422 6423 use Atree.Unchecked_Access; 6424 -- This code section is part of the implementation of an untyped 6425 -- tree traversal, so it needs direct access to node fields. 6426 6427 begin 6428 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 6429 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 6430 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 6431 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 6432 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 6433 end Copy_Descendants; 6434 6435 ----------------------------- 6436 -- Copy_Generic_Descendant -- 6437 ----------------------------- 6438 6439 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 6440 begin 6441 if D = Union_Id (Empty) then 6442 return D; 6443 6444 elsif D in Node_Range then 6445 return Union_Id 6446 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 6447 6448 elsif D in List_Range then 6449 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 6450 6451 elsif D in Elist_Range then 6452 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 6453 6454 -- Nothing else is copyable (e.g. Uint values), return as is 6455 6456 else 6457 return D; 6458 end if; 6459 end Copy_Generic_Descendant; 6460 6461 ------------------------ 6462 -- Copy_Generic_Elist -- 6463 ------------------------ 6464 6465 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 6466 M : Elmt_Id; 6467 L : Elist_Id; 6468 6469 begin 6470 if Present (E) then 6471 L := New_Elmt_List; 6472 M := First_Elmt (E); 6473 while Present (M) loop 6474 Append_Elmt 6475 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 6476 Next_Elmt (M); 6477 end loop; 6478 6479 return L; 6480 6481 else 6482 return No_Elist; 6483 end if; 6484 end Copy_Generic_Elist; 6485 6486 ----------------------- 6487 -- Copy_Generic_List -- 6488 ----------------------- 6489 6490 function Copy_Generic_List 6491 (L : List_Id; 6492 Parent_Id : Node_Id) return List_Id 6493 is 6494 N : Node_Id; 6495 New_L : List_Id; 6496 6497 begin 6498 if Present (L) then 6499 New_L := New_List; 6500 Set_Parent (New_L, Parent_Id); 6501 6502 N := First (L); 6503 while Present (N) loop 6504 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 6505 Next (N); 6506 end loop; 6507 6508 return New_L; 6509 6510 else 6511 return No_List; 6512 end if; 6513 end Copy_Generic_List; 6514 6515 --------------------------- 6516 -- In_Defining_Unit_Name -- 6517 --------------------------- 6518 6519 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 6520 begin 6521 return Present (Parent (Nam)) 6522 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 6523 or else 6524 (Nkind (Parent (Nam)) = N_Expanded_Name 6525 and then In_Defining_Unit_Name (Parent (Nam)))); 6526 end In_Defining_Unit_Name; 6527 6528 -- Start of processing for Copy_Generic_Node 6529 6530 begin 6531 if N = Empty then 6532 return N; 6533 end if; 6534 6535 New_N := New_Copy (N); 6536 6537 -- Copy aspects if present 6538 6539 if Has_Aspects (N) then 6540 Set_Has_Aspects (New_N, False); 6541 Set_Aspect_Specifications 6542 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 6543 end if; 6544 6545 if Instantiating then 6546 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 6547 end if; 6548 6549 if not Is_List_Member (N) then 6550 Set_Parent (New_N, Parent_Id); 6551 end if; 6552 6553 -- If defining identifier, then all fields have been copied already 6554 6555 if Nkind (New_N) in N_Entity then 6556 null; 6557 6558 -- Special casing for identifiers and other entity names and operators 6559 6560 elsif Nkind_In (New_N, N_Identifier, 6561 N_Character_Literal, 6562 N_Expanded_Name, 6563 N_Operator_Symbol) 6564 or else Nkind (New_N) in N_Op 6565 then 6566 if not Instantiating then 6567 6568 -- Link both nodes in order to assign subsequently the entity of 6569 -- the copy to the original node, in case this is a global 6570 -- reference. 6571 6572 Set_Associated_Node (N, New_N); 6573 6574 -- If we are within an instantiation, this is a nested generic 6575 -- that has already been analyzed at the point of definition. 6576 -- We must preserve references that were global to the enclosing 6577 -- parent at that point. Other occurrences, whether global or 6578 -- local to the current generic, must be resolved anew, so we 6579 -- reset the entity in the generic copy. A global reference has a 6580 -- smaller depth than the parent, or else the same depth in case 6581 -- both are distinct compilation units. 6582 6583 -- A child unit is implicitly declared within the enclosing parent 6584 -- but is in fact global to it, and must be preserved. 6585 6586 -- It is also possible for Current_Instantiated_Parent to be 6587 -- defined, and for this not to be a nested generic, namely if 6588 -- the unit is loaded through Rtsfind. In that case, the entity of 6589 -- New_N is only a link to the associated node, and not a defining 6590 -- occurrence. 6591 6592 -- The entities for parent units in the defining_program_unit of a 6593 -- generic child unit are established when the context of the unit 6594 -- is first analyzed, before the generic copy is made. They are 6595 -- preserved in the copy for use in ASIS queries. 6596 6597 Ent := Entity (New_N); 6598 6599 if No (Current_Instantiated_Parent.Gen_Id) then 6600 if No (Ent) 6601 or else Nkind (Ent) /= N_Defining_Identifier 6602 or else not In_Defining_Unit_Name (N) 6603 then 6604 Set_Associated_Node (New_N, Empty); 6605 end if; 6606 6607 elsif No (Ent) 6608 or else 6609 not Nkind_In (Ent, N_Defining_Identifier, 6610 N_Defining_Character_Literal, 6611 N_Defining_Operator_Symbol) 6612 or else No (Scope (Ent)) 6613 or else 6614 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 6615 and then not Is_Child_Unit (Ent)) 6616 or else 6617 (Scope_Depth (Scope (Ent)) > 6618 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 6619 and then 6620 Get_Source_Unit (Ent) = 6621 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 6622 then 6623 Set_Associated_Node (New_N, Empty); 6624 end if; 6625 6626 -- Case of instantiating identifier or some other name or operator 6627 6628 else 6629 -- If the associated node is still defined, the entity in it 6630 -- is global, and must be copied to the instance. If this copy 6631 -- is being made for a body to inline, it is applied to an 6632 -- instantiated tree, and the entity is already present and 6633 -- must be also preserved. 6634 6635 declare 6636 Assoc : constant Node_Id := Get_Associated_Node (N); 6637 6638 begin 6639 if Present (Assoc) then 6640 if Nkind (Assoc) = Nkind (N) then 6641 Set_Entity (New_N, Entity (Assoc)); 6642 Check_Private_View (N); 6643 6644 -- The name in the call may be a selected component if the 6645 -- call has not been analyzed yet, as may be the case for 6646 -- pre/post conditions in a generic unit. 6647 6648 elsif Nkind (Assoc) = N_Function_Call 6649 and then Is_Entity_Name (Name (Assoc)) 6650 then 6651 Set_Entity (New_N, Entity (Name (Assoc))); 6652 6653 elsif Nkind_In (Assoc, N_Defining_Identifier, 6654 N_Defining_Character_Literal, 6655 N_Defining_Operator_Symbol) 6656 and then Expander_Active 6657 then 6658 -- Inlining case: we are copying a tree that contains 6659 -- global entities, which are preserved in the copy to be 6660 -- used for subsequent inlining. 6661 6662 null; 6663 6664 else 6665 Set_Entity (New_N, Empty); 6666 end if; 6667 end if; 6668 end; 6669 end if; 6670 6671 -- For expanded name, we must copy the Prefix and Selector_Name 6672 6673 if Nkind (N) = N_Expanded_Name then 6674 Set_Prefix 6675 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 6676 6677 Set_Selector_Name (New_N, 6678 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 6679 6680 -- For operators, we must copy the right operand 6681 6682 elsif Nkind (N) in N_Op then 6683 Set_Right_Opnd (New_N, 6684 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 6685 6686 -- And for binary operators, the left operand as well 6687 6688 if Nkind (N) in N_Binary_Op then 6689 Set_Left_Opnd (New_N, 6690 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 6691 end if; 6692 end if; 6693 6694 -- Special casing for stubs 6695 6696 elsif Nkind (N) in N_Body_Stub then 6697 6698 -- In any case, we must copy the specification or defining 6699 -- identifier as appropriate. 6700 6701 if Nkind (N) = N_Subprogram_Body_Stub then 6702 Set_Specification (New_N, 6703 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 6704 6705 else 6706 Set_Defining_Identifier (New_N, 6707 Copy_Generic_Node 6708 (Defining_Identifier (N), New_N, Instantiating)); 6709 end if; 6710 6711 -- If we are not instantiating, then this is where we load and 6712 -- analyze subunits, i.e. at the point where the stub occurs. A 6713 -- more permissive system might defer this analysis to the point 6714 -- of instantiation, but this seems too complicated for now. 6715 6716 if not Instantiating then 6717 declare 6718 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 6719 Subunit : Node_Id; 6720 Unum : Unit_Number_Type; 6721 New_Body : Node_Id; 6722 6723 begin 6724 -- Make sure that, if it is a subunit of the main unit that is 6725 -- preprocessed and if -gnateG is specified, the preprocessed 6726 -- file will be written. 6727 6728 Lib.Analysing_Subunit_Of_Main := 6729 Lib.In_Extended_Main_Source_Unit (N); 6730 Unum := 6731 Load_Unit 6732 (Load_Name => Subunit_Name, 6733 Required => False, 6734 Subunit => True, 6735 Error_Node => N); 6736 Lib.Analysing_Subunit_Of_Main := False; 6737 6738 -- If the proper body is not found, a warning message will be 6739 -- emitted when analyzing the stub, or later at the point of 6740 -- instantiation. Here we just leave the stub as is. 6741 6742 if Unum = No_Unit then 6743 Subunits_Missing := True; 6744 goto Subunit_Not_Found; 6745 end if; 6746 6747 Subunit := Cunit (Unum); 6748 6749 if Nkind (Unit (Subunit)) /= N_Subunit then 6750 Error_Msg_N 6751 ("found child unit instead of expected SEPARATE subunit", 6752 Subunit); 6753 Error_Msg_Sloc := Sloc (N); 6754 Error_Msg_N ("\to complete stub #", Subunit); 6755 goto Subunit_Not_Found; 6756 end if; 6757 6758 -- We must create a generic copy of the subunit, in order to 6759 -- perform semantic analysis on it, and we must replace the 6760 -- stub in the original generic unit with the subunit, in order 6761 -- to preserve non-local references within. 6762 6763 -- Only the proper body needs to be copied. Library_Unit and 6764 -- context clause are simply inherited by the generic copy. 6765 -- Note that the copy (which may be recursive if there are 6766 -- nested subunits) must be done first, before attaching it to 6767 -- the enclosing generic. 6768 6769 New_Body := 6770 Copy_Generic_Node 6771 (Proper_Body (Unit (Subunit)), 6772 Empty, Instantiating => False); 6773 6774 -- Now place the original proper body in the original generic 6775 -- unit. This is a body, not a compilation unit. 6776 6777 Rewrite (N, Proper_Body (Unit (Subunit))); 6778 Set_Is_Compilation_Unit (Defining_Entity (N), False); 6779 Set_Was_Originally_Stub (N); 6780 6781 -- Finally replace the body of the subunit with its copy, and 6782 -- make this new subunit into the library unit of the generic 6783 -- copy, which does not have stubs any longer. 6784 6785 Set_Proper_Body (Unit (Subunit), New_Body); 6786 Set_Library_Unit (New_N, Subunit); 6787 Inherit_Context (Unit (Subunit), N); 6788 end; 6789 6790 -- If we are instantiating, this must be an error case, since 6791 -- otherwise we would have replaced the stub node by the proper body 6792 -- that corresponds. So just ignore it in the copy (i.e. we have 6793 -- copied it, and that is good enough). 6794 6795 else 6796 null; 6797 end if; 6798 6799 <<Subunit_Not_Found>> null; 6800 6801 -- If the node is a compilation unit, it is the subunit of a stub, which 6802 -- has been loaded already (see code below). In this case, the library 6803 -- unit field of N points to the parent unit (which is a compilation 6804 -- unit) and need not (and cannot) be copied. 6805 6806 -- When the proper body of the stub is analyzed, the library_unit link 6807 -- is used to establish the proper context (see sem_ch10). 6808 6809 -- The other fields of a compilation unit are copied as usual 6810 6811 elsif Nkind (N) = N_Compilation_Unit then 6812 6813 -- This code can only be executed when not instantiating, because in 6814 -- the copy made for an instantiation, the compilation unit node has 6815 -- disappeared at the point that a stub is replaced by its proper 6816 -- body. 6817 6818 pragma Assert (not Instantiating); 6819 6820 Set_Context_Items (New_N, 6821 Copy_Generic_List (Context_Items (N), New_N)); 6822 6823 Set_Unit (New_N, 6824 Copy_Generic_Node (Unit (N), New_N, False)); 6825 6826 Set_First_Inlined_Subprogram (New_N, 6827 Copy_Generic_Node 6828 (First_Inlined_Subprogram (N), New_N, False)); 6829 6830 Set_Aux_Decls_Node (New_N, 6831 Copy_Generic_Node (Aux_Decls_Node (N), New_N, False)); 6832 6833 -- For an assignment node, the assignment is known to be semantically 6834 -- legal if we are instantiating the template. This avoids incorrect 6835 -- diagnostics in generated code. 6836 6837 elsif Nkind (N) = N_Assignment_Statement then 6838 6839 -- Copy name and expression fields in usual manner 6840 6841 Set_Name (New_N, 6842 Copy_Generic_Node (Name (N), New_N, Instantiating)); 6843 6844 Set_Expression (New_N, 6845 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 6846 6847 if Instantiating then 6848 Set_Assignment_OK (Name (New_N), True); 6849 end if; 6850 6851 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 6852 if not Instantiating then 6853 Set_Associated_Node (N, New_N); 6854 6855 else 6856 if Present (Get_Associated_Node (N)) 6857 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 6858 then 6859 -- In the generic the aggregate has some composite type. If at 6860 -- the point of instantiation the type has a private view, 6861 -- install the full view (and that of its ancestors, if any). 6862 6863 declare 6864 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 6865 Rt : Entity_Id; 6866 6867 begin 6868 if Present (T) 6869 and then Is_Private_Type (T) 6870 then 6871 Switch_View (T); 6872 end if; 6873 6874 if Present (T) 6875 and then Is_Tagged_Type (T) 6876 and then Is_Derived_Type (T) 6877 then 6878 Rt := Root_Type (T); 6879 6880 loop 6881 T := Etype (T); 6882 6883 if Is_Private_Type (T) then 6884 Switch_View (T); 6885 end if; 6886 6887 exit when T = Rt; 6888 end loop; 6889 end if; 6890 end; 6891 end if; 6892 end if; 6893 6894 -- Do not copy the associated node, which points to the generic copy 6895 -- of the aggregate. 6896 6897 declare 6898 use Atree.Unchecked_Access; 6899 -- This code section is part of the implementation of an untyped 6900 -- tree traversal, so it needs direct access to node fields. 6901 6902 begin 6903 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 6904 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 6905 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 6906 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 6907 end; 6908 6909 -- Allocators do not have an identifier denoting the access type, so we 6910 -- must locate it through the expression to check whether the views are 6911 -- consistent. 6912 6913 elsif Nkind (N) = N_Allocator 6914 and then Nkind (Expression (N)) = N_Qualified_Expression 6915 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 6916 and then Instantiating 6917 then 6918 declare 6919 T : constant Node_Id := 6920 Get_Associated_Node (Subtype_Mark (Expression (N))); 6921 Acc_T : Entity_Id; 6922 6923 begin 6924 if Present (T) then 6925 6926 -- Retrieve the allocator node in the generic copy 6927 6928 Acc_T := Etype (Parent (Parent (T))); 6929 if Present (Acc_T) 6930 and then Is_Private_Type (Acc_T) 6931 then 6932 Switch_View (Acc_T); 6933 end if; 6934 end if; 6935 6936 Copy_Descendants; 6937 end; 6938 6939 -- For a proper body, we must catch the case of a proper body that 6940 -- replaces a stub. This represents the point at which a separate 6941 -- compilation unit, and hence template file, may be referenced, so we 6942 -- must make a new source instantiation entry for the template of the 6943 -- subunit, and ensure that all nodes in the subunit are adjusted using 6944 -- this new source instantiation entry. 6945 6946 elsif Nkind (N) in N_Proper_Body then 6947 declare 6948 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 6949 6950 begin 6951 if Instantiating and then Was_Originally_Stub (N) then 6952 Create_Instantiation_Source 6953 (Instantiation_Node, 6954 Defining_Entity (N), 6955 False, 6956 S_Adjustment); 6957 end if; 6958 6959 -- Now copy the fields of the proper body, using the new 6960 -- adjustment factor if one was needed as per test above. 6961 6962 Copy_Descendants; 6963 6964 -- Restore the original adjustment factor in case changed 6965 6966 S_Adjustment := Save_Adjustment; 6967 end; 6968 6969 -- Don't copy Ident or Comment pragmas, since the comment belongs to the 6970 -- generic unit, not to the instantiating unit. 6971 6972 elsif Nkind (N) = N_Pragma and then Instantiating then 6973 declare 6974 Prag_Id : constant Pragma_Id := Get_Pragma_Id (N); 6975 begin 6976 if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then 6977 New_N := Make_Null_Statement (Sloc (N)); 6978 else 6979 Copy_Descendants; 6980 end if; 6981 end; 6982 6983 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 6984 6985 -- No descendant fields need traversing 6986 6987 null; 6988 6989 elsif Nkind (N) = N_String_Literal 6990 and then Present (Etype (N)) 6991 and then Instantiating 6992 then 6993 -- If the string is declared in an outer scope, the string_literal 6994 -- subtype created for it may have the wrong scope. We force the 6995 -- reanalysis of the constant to generate a new itype in the proper 6996 -- context. 6997 6998 Set_Etype (New_N, Empty); 6999 Set_Analyzed (New_N, False); 7000 7001 -- For the remaining nodes, copy their descendants recursively 7002 7003 else 7004 Copy_Descendants; 7005 7006 if Instantiating and then Nkind (N) = N_Subprogram_Body then 7007 Set_Generic_Parent (Specification (New_N), N); 7008 7009 -- Should preserve Corresponding_Spec??? (12.3(14)) 7010 end if; 7011 end if; 7012 7013 return New_N; 7014 end Copy_Generic_Node; 7015 7016 ---------------------------- 7017 -- Denotes_Formal_Package -- 7018 ---------------------------- 7019 7020 function Denotes_Formal_Package 7021 (Pack : Entity_Id; 7022 On_Exit : Boolean := False; 7023 Instance : Entity_Id := Empty) return Boolean 7024 is 7025 Par : Entity_Id; 7026 Scop : constant Entity_Id := Scope (Pack); 7027 E : Entity_Id; 7028 7029 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 7030 -- The package in question may be an actual for a previous formal 7031 -- package P of the current instance, so examine its actuals as well. 7032 -- This must be recursive over other formal packages. 7033 7034 ---------------------------------- 7035 -- Is_Actual_Of_Previous_Formal -- 7036 ---------------------------------- 7037 7038 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 7039 E1 : Entity_Id; 7040 7041 begin 7042 E1 := First_Entity (P); 7043 while Present (E1) and then E1 /= Instance loop 7044 if Ekind (E1) = E_Package 7045 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 7046 then 7047 if Renamed_Object (E1) = Pack then 7048 return True; 7049 7050 elsif E1 = P or else Renamed_Object (E1) = P then 7051 return False; 7052 7053 elsif Is_Actual_Of_Previous_Formal (E1) then 7054 return True; 7055 end if; 7056 end if; 7057 7058 Next_Entity (E1); 7059 end loop; 7060 7061 return False; 7062 end Is_Actual_Of_Previous_Formal; 7063 7064 -- Start of processing for Denotes_Formal_Package 7065 7066 begin 7067 if On_Exit then 7068 Par := 7069 Instance_Envs.Table 7070 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 7071 else 7072 Par := Current_Instantiated_Parent.Act_Id; 7073 end if; 7074 7075 if Ekind (Scop) = E_Generic_Package 7076 or else Nkind (Unit_Declaration_Node (Scop)) = 7077 N_Generic_Subprogram_Declaration 7078 then 7079 return True; 7080 7081 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 7082 N_Formal_Package_Declaration 7083 then 7084 return True; 7085 7086 elsif No (Par) then 7087 return False; 7088 7089 else 7090 -- Check whether this package is associated with a formal package of 7091 -- the enclosing instantiation. Iterate over the list of renamings. 7092 7093 E := First_Entity (Par); 7094 while Present (E) loop 7095 if Ekind (E) /= E_Package 7096 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 7097 then 7098 null; 7099 7100 elsif Renamed_Object (E) = Par then 7101 return False; 7102 7103 elsif Renamed_Object (E) = Pack then 7104 return True; 7105 7106 elsif Is_Actual_Of_Previous_Formal (E) then 7107 return True; 7108 7109 end if; 7110 7111 Next_Entity (E); 7112 end loop; 7113 7114 return False; 7115 end if; 7116 end Denotes_Formal_Package; 7117 7118 ----------------- 7119 -- End_Generic -- 7120 ----------------- 7121 7122 procedure End_Generic is 7123 begin 7124 -- ??? More things could be factored out in this routine. Should 7125 -- probably be done at a later stage. 7126 7127 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 7128 Generic_Flags.Decrement_Last; 7129 7130 Expander_Mode_Restore; 7131 end End_Generic; 7132 7133 ------------- 7134 -- Earlier -- 7135 ------------- 7136 7137 function Earlier (N1, N2 : Node_Id) return Boolean is 7138 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 7139 -- Find distance from given node to enclosing compilation unit 7140 7141 ---------------- 7142 -- Find_Depth -- 7143 ---------------- 7144 7145 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 7146 begin 7147 while Present (P) 7148 and then Nkind (P) /= N_Compilation_Unit 7149 loop 7150 P := True_Parent (P); 7151 D := D + 1; 7152 end loop; 7153 end Find_Depth; 7154 7155 -- Local declarations 7156 7157 D1 : Integer := 0; 7158 D2 : Integer := 0; 7159 P1 : Node_Id := N1; 7160 P2 : Node_Id := N2; 7161 T1 : Source_Ptr; 7162 T2 : Source_Ptr; 7163 7164 -- Start of processing for Earlier 7165 7166 begin 7167 Find_Depth (P1, D1); 7168 Find_Depth (P2, D2); 7169 7170 if P1 /= P2 then 7171 return False; 7172 else 7173 P1 := N1; 7174 P2 := N2; 7175 end if; 7176 7177 while D1 > D2 loop 7178 P1 := True_Parent (P1); 7179 D1 := D1 - 1; 7180 end loop; 7181 7182 while D2 > D1 loop 7183 P2 := True_Parent (P2); 7184 D2 := D2 - 1; 7185 end loop; 7186 7187 -- At this point P1 and P2 are at the same distance from the root. 7188 -- We examine their parents until we find a common declarative list. 7189 -- If we reach the root, N1 and N2 do not descend from the same 7190 -- declarative list (e.g. one is nested in the declarative part and 7191 -- the other is in a block in the statement part) and the earlier 7192 -- one is already frozen. 7193 7194 while not Is_List_Member (P1) 7195 or else not Is_List_Member (P2) 7196 or else List_Containing (P1) /= List_Containing (P2) 7197 loop 7198 P1 := True_Parent (P1); 7199 P2 := True_Parent (P2); 7200 7201 if Nkind (Parent (P1)) = N_Subunit then 7202 P1 := Corresponding_Stub (Parent (P1)); 7203 end if; 7204 7205 if Nkind (Parent (P2)) = N_Subunit then 7206 P2 := Corresponding_Stub (Parent (P2)); 7207 end if; 7208 7209 if P1 = P2 then 7210 return False; 7211 end if; 7212 end loop; 7213 7214 -- Expanded code usually shares the source location of the original 7215 -- construct it was generated for. This however may not necessarely 7216 -- reflect the true location of the code within the tree. 7217 7218 -- Before comparing the slocs of the two nodes, make sure that we are 7219 -- working with correct source locations. Assume that P1 is to the left 7220 -- of P2. If either one does not come from source, traverse the common 7221 -- list heading towards the other node and locate the first source 7222 -- statement. 7223 7224 -- P1 P2 7225 -- ----+===+===+--------------+===+===+---- 7226 -- expanded code expanded code 7227 7228 if not Comes_From_Source (P1) then 7229 while Present (P1) loop 7230 7231 -- Neither P2 nor a source statement were located during the 7232 -- search. If we reach the end of the list, then P1 does not 7233 -- occur earlier than P2. 7234 7235 -- ----> 7236 -- start --- P2 ----- P1 --- end 7237 7238 if No (Next (P1)) then 7239 return False; 7240 7241 -- We encounter P2 while going to the right of the list. This 7242 -- means that P1 does indeed appear earlier. 7243 7244 -- ----> 7245 -- start --- P1 ===== P2 --- end 7246 -- expanded code in between 7247 7248 elsif P1 = P2 then 7249 return True; 7250 7251 -- No need to look any further since we have located a source 7252 -- statement. 7253 7254 elsif Comes_From_Source (P1) then 7255 exit; 7256 end if; 7257 7258 -- Keep going right 7259 7260 Next (P1); 7261 end loop; 7262 end if; 7263 7264 if not Comes_From_Source (P2) then 7265 while Present (P2) loop 7266 7267 -- Neither P1 nor a source statement were located during the 7268 -- search. If we reach the start of the list, then P1 does not 7269 -- occur earlier than P2. 7270 7271 -- <---- 7272 -- start --- P2 --- P1 --- end 7273 7274 if No (Prev (P2)) then 7275 return False; 7276 7277 -- We encounter P1 while going to the left of the list. This 7278 -- means that P1 does indeed appear earlier. 7279 7280 -- <---- 7281 -- start --- P1 ===== P2 --- end 7282 -- expanded code in between 7283 7284 elsif P2 = P1 then 7285 return True; 7286 7287 -- No need to look any further since we have located a source 7288 -- statement. 7289 7290 elsif Comes_From_Source (P2) then 7291 exit; 7292 end if; 7293 7294 -- Keep going left 7295 7296 Prev (P2); 7297 end loop; 7298 end if; 7299 7300 -- At this point either both nodes came from source or we approximated 7301 -- their source locations through neighbouring source statements. 7302 7303 T1 := Top_Level_Location (Sloc (P1)); 7304 T2 := Top_Level_Location (Sloc (P2)); 7305 7306 -- When two nodes come from the same instance, they have identical top 7307 -- level locations. To determine proper relation within the tree, check 7308 -- their locations within the template. 7309 7310 if T1 = T2 then 7311 return Sloc (P1) < Sloc (P2); 7312 7313 -- The two nodes either come from unrelated instances or do not come 7314 -- from instantiated code at all. 7315 7316 else 7317 return T1 < T2; 7318 end if; 7319 end Earlier; 7320 7321 ---------------------- 7322 -- Find_Actual_Type -- 7323 ---------------------- 7324 7325 function Find_Actual_Type 7326 (Typ : Entity_Id; 7327 Gen_Type : Entity_Id) return Entity_Id 7328 is 7329 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 7330 T : Entity_Id; 7331 7332 begin 7333 -- Special processing only applies to child units 7334 7335 if not Is_Child_Unit (Gen_Scope) then 7336 return Get_Instance_Of (Typ); 7337 7338 -- If designated or component type is itself a formal of the child unit, 7339 -- its instance is available. 7340 7341 elsif Scope (Typ) = Gen_Scope then 7342 return Get_Instance_Of (Typ); 7343 7344 -- If the array or access type is not declared in the parent unit, 7345 -- no special processing needed. 7346 7347 elsif not Is_Generic_Type (Typ) 7348 and then Scope (Gen_Scope) /= Scope (Typ) 7349 then 7350 return Get_Instance_Of (Typ); 7351 7352 -- Otherwise, retrieve designated or component type by visibility 7353 7354 else 7355 T := Current_Entity (Typ); 7356 while Present (T) loop 7357 if In_Open_Scopes (Scope (T)) then 7358 return T; 7359 7360 elsif Is_Generic_Actual_Type (T) then 7361 return T; 7362 end if; 7363 7364 T := Homonym (T); 7365 end loop; 7366 7367 return Typ; 7368 end if; 7369 end Find_Actual_Type; 7370 7371 ---------------------------- 7372 -- Freeze_Subprogram_Body -- 7373 ---------------------------- 7374 7375 procedure Freeze_Subprogram_Body 7376 (Inst_Node : Node_Id; 7377 Gen_Body : Node_Id; 7378 Pack_Id : Entity_Id) 7379 is 7380 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 7381 Par : constant Entity_Id := Scope (Gen_Unit); 7382 E_G_Id : Entity_Id; 7383 Enc_G : Entity_Id; 7384 Enc_I : Node_Id; 7385 F_Node : Node_Id; 7386 7387 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 7388 -- Find innermost package body that encloses the given node, and which 7389 -- is not a compilation unit. Freeze nodes for the instance, or for its 7390 -- enclosing body, may be inserted after the enclosing_body of the 7391 -- generic unit. Used to determine proper placement of freeze node for 7392 -- both package and subprogram instances. 7393 7394 function Package_Freeze_Node (B : Node_Id) return Node_Id; 7395 -- Find entity for given package body, and locate or create a freeze 7396 -- node for it. 7397 7398 ---------------------------- 7399 -- Enclosing_Package_Body -- 7400 ---------------------------- 7401 7402 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 7403 P : Node_Id; 7404 7405 begin 7406 P := Parent (N); 7407 while Present (P) 7408 and then Nkind (Parent (P)) /= N_Compilation_Unit 7409 loop 7410 if Nkind (P) = N_Package_Body then 7411 if Nkind (Parent (P)) = N_Subunit then 7412 return Corresponding_Stub (Parent (P)); 7413 else 7414 return P; 7415 end if; 7416 end if; 7417 7418 P := True_Parent (P); 7419 end loop; 7420 7421 return Empty; 7422 end Enclosing_Package_Body; 7423 7424 ------------------------- 7425 -- Package_Freeze_Node -- 7426 ------------------------- 7427 7428 function Package_Freeze_Node (B : Node_Id) return Node_Id is 7429 Id : Entity_Id; 7430 7431 begin 7432 if Nkind (B) = N_Package_Body then 7433 Id := Corresponding_Spec (B); 7434 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 7435 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 7436 end if; 7437 7438 Ensure_Freeze_Node (Id); 7439 return Freeze_Node (Id); 7440 end Package_Freeze_Node; 7441 7442 -- Start of processing of Freeze_Subprogram_Body 7443 7444 begin 7445 -- If the instance and the generic body appear within the same unit, and 7446 -- the instance precedes the generic, the freeze node for the instance 7447 -- must appear after that of the generic. If the generic is nested 7448 -- within another instance I2, then current instance must be frozen 7449 -- after I2. In both cases, the freeze nodes are those of enclosing 7450 -- packages. Otherwise, the freeze node is placed at the end of the 7451 -- current declarative part. 7452 7453 Enc_G := Enclosing_Package_Body (Gen_Body); 7454 Enc_I := Enclosing_Package_Body (Inst_Node); 7455 Ensure_Freeze_Node (Pack_Id); 7456 F_Node := Freeze_Node (Pack_Id); 7457 7458 if Is_Generic_Instance (Par) 7459 and then Present (Freeze_Node (Par)) 7460 and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node) 7461 then 7462 -- The parent was a premature instantiation. Insert freeze node at 7463 -- the end the current declarative part. 7464 7465 if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then 7466 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7467 7468 -- Handle the following case: 7469 -- 7470 -- package Parent_Inst is new ... 7471 -- Parent_Inst [] 7472 -- 7473 -- procedure P ... -- this body freezes Parent_Inst 7474 -- 7475 -- package Inst is new ... 7476 -- 7477 -- In this particular scenario, the freeze node for Inst must be 7478 -- inserted in the same manner as that of Parent_Inst - before the 7479 -- next source body or at the end of the declarative list (body not 7480 -- available). If body P did not exist and Parent_Inst was frozen 7481 -- after Inst, either by a body following Inst or at the end of the 7482 -- declarative region, the freeze node for Inst must be inserted 7483 -- after that of Parent_Inst. This relation is established by 7484 -- comparing the Slocs of Parent_Inst freeze node and Inst. 7485 7486 elsif List_Containing (Get_Package_Instantiation_Node (Par)) = 7487 List_Containing (Inst_Node) 7488 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 7489 then 7490 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7491 7492 else 7493 Insert_After (Freeze_Node (Par), F_Node); 7494 end if; 7495 7496 -- The body enclosing the instance should be frozen after the body that 7497 -- includes the generic, because the body of the instance may make 7498 -- references to entities therein. If the two are not in the same 7499 -- declarative part, or if the one enclosing the instance is frozen 7500 -- already, freeze the instance at the end of the current declarative 7501 -- part. 7502 7503 elsif Is_Generic_Instance (Par) 7504 and then Present (Freeze_Node (Par)) 7505 and then Present (Enc_I) 7506 then 7507 if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I) 7508 or else 7509 (Nkind (Enc_I) = N_Package_Body 7510 and then 7511 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I))) 7512 then 7513 -- The enclosing package may contain several instances. Rather 7514 -- than computing the earliest point at which to insert its freeze 7515 -- node, we place it at the end of the declarative part of the 7516 -- parent of the generic. 7517 7518 Insert_Freeze_Node_For_Instance 7519 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 7520 end if; 7521 7522 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7523 7524 elsif Present (Enc_G) 7525 and then Present (Enc_I) 7526 and then Enc_G /= Enc_I 7527 and then Earlier (Inst_Node, Gen_Body) 7528 then 7529 if Nkind (Enc_G) = N_Package_Body then 7530 E_G_Id := Corresponding_Spec (Enc_G); 7531 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 7532 E_G_Id := 7533 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 7534 end if; 7535 7536 -- Freeze package that encloses instance, and place node after the 7537 -- package that encloses generic. If enclosing package is already 7538 -- frozen we have to assume it is at the proper place. This may be a 7539 -- potential ABE that requires dynamic checking. Do not add a freeze 7540 -- node if the package that encloses the generic is inside the body 7541 -- that encloses the instance, because the freeze node would be in 7542 -- the wrong scope. Additional contortions needed if the bodies are 7543 -- within a subunit. 7544 7545 declare 7546 Enclosing_Body : Node_Id; 7547 7548 begin 7549 if Nkind (Enc_I) = N_Package_Body_Stub then 7550 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 7551 else 7552 Enclosing_Body := Enc_I; 7553 end if; 7554 7555 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 7556 Insert_Freeze_Node_For_Instance 7557 (Enc_G, Package_Freeze_Node (Enc_I)); 7558 end if; 7559 end; 7560 7561 -- Freeze enclosing subunit before instance 7562 7563 Ensure_Freeze_Node (E_G_Id); 7564 7565 if not Is_List_Member (Freeze_Node (E_G_Id)) then 7566 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 7567 end if; 7568 7569 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7570 7571 else 7572 -- If none of the above, insert freeze node at the end of the current 7573 -- declarative part. 7574 7575 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 7576 end if; 7577 end Freeze_Subprogram_Body; 7578 7579 ---------------- 7580 -- Get_Gen_Id -- 7581 ---------------- 7582 7583 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 7584 begin 7585 return Generic_Renamings.Table (E).Gen_Id; 7586 end Get_Gen_Id; 7587 7588 --------------------- 7589 -- Get_Instance_Of -- 7590 --------------------- 7591 7592 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 7593 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 7594 7595 begin 7596 if Res /= Assoc_Null then 7597 return Generic_Renamings.Table (Res).Act_Id; 7598 else 7599 -- On exit, entity is not instantiated: not a generic parameter, or 7600 -- else parameter of an inner generic unit. 7601 7602 return A; 7603 end if; 7604 end Get_Instance_Of; 7605 7606 ------------------------------------ 7607 -- Get_Package_Instantiation_Node -- 7608 ------------------------------------ 7609 7610 function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is 7611 Decl : Node_Id := Unit_Declaration_Node (A); 7612 Inst : Node_Id; 7613 7614 begin 7615 -- If the Package_Instantiation attribute has been set on the package 7616 -- entity, then use it directly when it (or its Original_Node) refers 7617 -- to an N_Package_Instantiation node. In principle it should be 7618 -- possible to have this field set in all cases, which should be 7619 -- investigated, and would allow this function to be significantly 7620 -- simplified. ??? 7621 7622 Inst := Package_Instantiation (A); 7623 7624 if Present (Inst) then 7625 if Nkind (Inst) = N_Package_Instantiation then 7626 return Inst; 7627 7628 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 7629 return Original_Node (Inst); 7630 end if; 7631 end if; 7632 7633 -- If the instantiation is a compilation unit that does not need body 7634 -- then the instantiation node has been rewritten as a package 7635 -- declaration for the instance, and we return the original node. 7636 7637 -- If it is a compilation unit and the instance node has not been 7638 -- rewritten, then it is still the unit of the compilation. Finally, if 7639 -- a body is present, this is a parent of the main unit whose body has 7640 -- been compiled for inlining purposes, and the instantiation node has 7641 -- been rewritten with the instance body. 7642 7643 -- Otherwise the instantiation node appears after the declaration. If 7644 -- the entity is a formal package, the declaration may have been 7645 -- rewritten as a generic declaration (in the case of a formal with box) 7646 -- or left as a formal package declaration if it has actuals, and is 7647 -- found with a forward search. 7648 7649 if Nkind (Parent (Decl)) = N_Compilation_Unit then 7650 if Nkind (Decl) = N_Package_Declaration 7651 and then Present (Corresponding_Body (Decl)) 7652 then 7653 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 7654 end if; 7655 7656 if Nkind (Original_Node (Decl)) = N_Package_Instantiation then 7657 return Original_Node (Decl); 7658 else 7659 return Unit (Parent (Decl)); 7660 end if; 7661 7662 elsif Nkind (Decl) = N_Package_Declaration 7663 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 7664 then 7665 return Original_Node (Decl); 7666 7667 else 7668 Inst := Next (Decl); 7669 while not Nkind_In (Inst, N_Package_Instantiation, 7670 N_Formal_Package_Declaration) 7671 loop 7672 Next (Inst); 7673 end loop; 7674 7675 return Inst; 7676 end if; 7677 end Get_Package_Instantiation_Node; 7678 7679 ------------------------ 7680 -- Has_Been_Exchanged -- 7681 ------------------------ 7682 7683 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 7684 Next : Elmt_Id; 7685 7686 begin 7687 Next := First_Elmt (Exchanged_Views); 7688 while Present (Next) loop 7689 if Full_View (Node (Next)) = E then 7690 return True; 7691 end if; 7692 7693 Next_Elmt (Next); 7694 end loop; 7695 7696 return False; 7697 end Has_Been_Exchanged; 7698 7699 ---------- 7700 -- Hash -- 7701 ---------- 7702 7703 function Hash (F : Entity_Id) return HTable_Range is 7704 begin 7705 return HTable_Range (F mod HTable_Size); 7706 end Hash; 7707 7708 ------------------------ 7709 -- Hide_Current_Scope -- 7710 ------------------------ 7711 7712 procedure Hide_Current_Scope is 7713 C : constant Entity_Id := Current_Scope; 7714 E : Entity_Id; 7715 7716 begin 7717 Set_Is_Hidden_Open_Scope (C); 7718 7719 E := First_Entity (C); 7720 while Present (E) loop 7721 if Is_Immediately_Visible (E) then 7722 Set_Is_Immediately_Visible (E, False); 7723 Append_Elmt (E, Hidden_Entities); 7724 end if; 7725 7726 Next_Entity (E); 7727 end loop; 7728 7729 -- Make the scope name invisible as well. This is necessary, but might 7730 -- conflict with calls to Rtsfind later on, in case the scope is a 7731 -- predefined one. There is no clean solution to this problem, so for 7732 -- now we depend on the user not redefining Standard itself in one of 7733 -- the parent units. 7734 7735 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 7736 Set_Is_Immediately_Visible (C, False); 7737 Append_Elmt (C, Hidden_Entities); 7738 end if; 7739 7740 end Hide_Current_Scope; 7741 7742 -------------- 7743 -- Init_Env -- 7744 -------------- 7745 7746 procedure Init_Env is 7747 Saved : Instance_Env; 7748 7749 begin 7750 Saved.Instantiated_Parent := Current_Instantiated_Parent; 7751 Saved.Exchanged_Views := Exchanged_Views; 7752 Saved.Hidden_Entities := Hidden_Entities; 7753 Saved.Current_Sem_Unit := Current_Sem_Unit; 7754 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 7755 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 7756 7757 -- Save configuration switches. These may be reset if the unit is a 7758 -- predefined unit, and the current mode is not Ada 2005. 7759 7760 Save_Opt_Config_Switches (Saved.Switches); 7761 7762 Instance_Envs.Append (Saved); 7763 7764 Exchanged_Views := New_Elmt_List; 7765 Hidden_Entities := New_Elmt_List; 7766 7767 -- Make dummy entry for Instantiated parent. If generic unit is legal, 7768 -- this is set properly in Set_Instance_Env. 7769 7770 Current_Instantiated_Parent := 7771 (Current_Scope, Current_Scope, Assoc_Null); 7772 end Init_Env; 7773 7774 ------------------------------ 7775 -- In_Same_Declarative_Part -- 7776 ------------------------------ 7777 7778 function In_Same_Declarative_Part 7779 (F_Node : Node_Id; 7780 Inst : Node_Id) return Boolean 7781 is 7782 Decls : constant Node_Id := Parent (F_Node); 7783 Nod : Node_Id := Parent (Inst); 7784 7785 begin 7786 while Present (Nod) loop 7787 if Nod = Decls then 7788 return True; 7789 7790 elsif Nkind_In (Nod, N_Subprogram_Body, 7791 N_Package_Body, 7792 N_Package_Declaration, 7793 N_Task_Body, 7794 N_Protected_Body, 7795 N_Block_Statement) 7796 then 7797 return False; 7798 7799 elsif Nkind (Nod) = N_Subunit then 7800 Nod := Corresponding_Stub (Nod); 7801 7802 elsif Nkind (Nod) = N_Compilation_Unit then 7803 return False; 7804 7805 else 7806 Nod := Parent (Nod); 7807 end if; 7808 end loop; 7809 7810 return False; 7811 end In_Same_Declarative_Part; 7812 7813 --------------------- 7814 -- In_Main_Context -- 7815 --------------------- 7816 7817 function In_Main_Context (E : Entity_Id) return Boolean is 7818 Context : List_Id; 7819 Clause : Node_Id; 7820 Nam : Node_Id; 7821 7822 begin 7823 if not Is_Compilation_Unit (E) 7824 or else Ekind (E) /= E_Package 7825 or else In_Private_Part (E) 7826 then 7827 return False; 7828 end if; 7829 7830 Context := Context_Items (Cunit (Main_Unit)); 7831 7832 Clause := First (Context); 7833 while Present (Clause) loop 7834 if Nkind (Clause) = N_With_Clause then 7835 Nam := Name (Clause); 7836 7837 -- If the current scope is part of the context of the main unit, 7838 -- analysis of the corresponding with_clause is not complete, and 7839 -- the entity is not set. We use the Chars field directly, which 7840 -- might produce false positives in rare cases, but guarantees 7841 -- that we produce all the instance bodies we will need. 7842 7843 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 7844 or else (Nkind (Nam) = N_Selected_Component 7845 and then Chars (Selector_Name (Nam)) = Chars (E)) 7846 then 7847 return True; 7848 end if; 7849 end if; 7850 7851 Next (Clause); 7852 end loop; 7853 7854 return False; 7855 end In_Main_Context; 7856 7857 --------------------- 7858 -- Inherit_Context -- 7859 --------------------- 7860 7861 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 7862 Current_Context : List_Id; 7863 Current_Unit : Node_Id; 7864 Item : Node_Id; 7865 New_I : Node_Id; 7866 7867 Clause : Node_Id; 7868 OK : Boolean; 7869 Lib_Unit : Node_Id; 7870 7871 begin 7872 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 7873 7874 -- The inherited context is attached to the enclosing compilation 7875 -- unit. This is either the main unit, or the declaration for the 7876 -- main unit (in case the instantiation appears within the package 7877 -- declaration and the main unit is its body). 7878 7879 Current_Unit := Parent (Inst); 7880 while Present (Current_Unit) 7881 and then Nkind (Current_Unit) /= N_Compilation_Unit 7882 loop 7883 Current_Unit := Parent (Current_Unit); 7884 end loop; 7885 7886 Current_Context := Context_Items (Current_Unit); 7887 7888 Item := First (Context_Items (Parent (Gen_Decl))); 7889 while Present (Item) loop 7890 if Nkind (Item) = N_With_Clause then 7891 Lib_Unit := Library_Unit (Item); 7892 7893 -- Take care to prevent direct cyclic with's 7894 7895 if Lib_Unit /= Current_Unit then 7896 7897 -- Do not add a unit if it is already in the context 7898 7899 Clause := First (Current_Context); 7900 OK := True; 7901 while Present (Clause) loop 7902 if Nkind (Clause) = N_With_Clause and then 7903 Library_Unit (Clause) = Lib_Unit 7904 then 7905 OK := False; 7906 exit; 7907 end if; 7908 7909 Next (Clause); 7910 end loop; 7911 7912 if OK then 7913 New_I := New_Copy (Item); 7914 Set_Implicit_With (New_I, True); 7915 Set_Implicit_With_From_Instantiation (New_I, True); 7916 Append (New_I, Current_Context); 7917 end if; 7918 end if; 7919 end if; 7920 7921 Next (Item); 7922 end loop; 7923 end if; 7924 end Inherit_Context; 7925 7926 ---------------- 7927 -- Initialize -- 7928 ---------------- 7929 7930 procedure Initialize is 7931 begin 7932 Generic_Renamings.Init; 7933 Instance_Envs.Init; 7934 Generic_Flags.Init; 7935 Generic_Renamings_HTable.Reset; 7936 Circularity_Detected := False; 7937 Exchanged_Views := No_Elist; 7938 Hidden_Entities := No_Elist; 7939 end Initialize; 7940 7941 ------------------------------------- 7942 -- Insert_Freeze_Node_For_Instance -- 7943 ------------------------------------- 7944 7945 procedure Insert_Freeze_Node_For_Instance 7946 (N : Node_Id; 7947 F_Node : Node_Id) 7948 is 7949 Decl : Node_Id; 7950 Decls : List_Id; 7951 Inst : Entity_Id; 7952 Par_N : Node_Id; 7953 7954 function Enclosing_Body (N : Node_Id) return Node_Id; 7955 -- Find enclosing package or subprogram body, if any. Freeze node may 7956 -- be placed at end of current declarative list if previous instance 7957 -- and current one have different enclosing bodies. 7958 7959 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 7960 -- Find the local instance, if any, that declares the generic that is 7961 -- being instantiated. If present, the freeze node for this instance 7962 -- must follow the freeze node for the previous instance. 7963 7964 -------------------- 7965 -- Enclosing_Body -- 7966 -------------------- 7967 7968 function Enclosing_Body (N : Node_Id) return Node_Id is 7969 P : Node_Id; 7970 7971 begin 7972 P := Parent (N); 7973 while Present (P) 7974 and then Nkind (Parent (P)) /= N_Compilation_Unit 7975 loop 7976 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 7977 if Nkind (Parent (P)) = N_Subunit then 7978 return Corresponding_Stub (Parent (P)); 7979 else 7980 return P; 7981 end if; 7982 end if; 7983 7984 P := True_Parent (P); 7985 end loop; 7986 7987 return Empty; 7988 end Enclosing_Body; 7989 7990 ----------------------- 7991 -- Previous_Instance -- 7992 ----------------------- 7993 7994 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 7995 S : Entity_Id; 7996 7997 begin 7998 S := Scope (Gen); 7999 while Present (S) 8000 and then S /= Standard_Standard 8001 loop 8002 if Is_Generic_Instance (S) 8003 and then In_Same_Source_Unit (S, N) 8004 then 8005 return S; 8006 end if; 8007 8008 S := Scope (S); 8009 end loop; 8010 8011 return Empty; 8012 end Previous_Instance; 8013 8014 -- Start of processing for Insert_Freeze_Node_For_Instance 8015 8016 begin 8017 if not Is_List_Member (F_Node) then 8018 Decl := N; 8019 Decls := List_Containing (N); 8020 Inst := Entity (F_Node); 8021 Par_N := Parent (Decls); 8022 8023 -- When processing a subprogram instantiation, utilize the actual 8024 -- subprogram instantiation rather than its package wrapper as it 8025 -- carries all the context information. 8026 8027 if Is_Wrapper_Package (Inst) then 8028 Inst := Related_Instance (Inst); 8029 end if; 8030 8031 -- If this is a package instance, check whether the generic is 8032 -- declared in a previous instance and the current instance is 8033 -- not within the previous one. 8034 8035 if Present (Generic_Parent (Parent (Inst))) 8036 and then Is_In_Main_Unit (N) 8037 then 8038 declare 8039 Enclosing_N : constant Node_Id := Enclosing_Body (N); 8040 Par_I : constant Entity_Id := 8041 Previous_Instance 8042 (Generic_Parent (Parent (Inst))); 8043 Scop : Entity_Id; 8044 8045 begin 8046 if Present (Par_I) 8047 and then Earlier (N, Freeze_Node (Par_I)) 8048 then 8049 Scop := Scope (Inst); 8050 8051 -- If the current instance is within the one that contains 8052 -- the generic, the freeze node for the current one must 8053 -- appear in the current declarative part. Ditto, if the 8054 -- current instance is within another package instance or 8055 -- within a body that does not enclose the current instance. 8056 -- In these three cases the freeze node of the previous 8057 -- instance is not relevant. 8058 8059 while Present (Scop) 8060 and then Scop /= Standard_Standard 8061 loop 8062 exit when Scop = Par_I 8063 or else 8064 (Is_Generic_Instance (Scop) 8065 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 8066 Scop := Scope (Scop); 8067 end loop; 8068 8069 -- Previous instance encloses current instance 8070 8071 if Scop = Par_I then 8072 null; 8073 8074 -- If the next node is a source body we must freeze in 8075 -- the current scope as well. 8076 8077 elsif Present (Next (N)) 8078 and then Nkind_In (Next (N), 8079 N_Subprogram_Body, N_Package_Body) 8080 and then Comes_From_Source (Next (N)) 8081 then 8082 null; 8083 8084 -- Current instance is within an unrelated instance 8085 8086 elsif Is_Generic_Instance (Scop) then 8087 null; 8088 8089 -- Current instance is within an unrelated body 8090 8091 elsif Present (Enclosing_N) 8092 and then Enclosing_N /= Enclosing_Body (Par_I) 8093 then 8094 null; 8095 8096 else 8097 Insert_After (Freeze_Node (Par_I), F_Node); 8098 return; 8099 end if; 8100 end if; 8101 end; 8102 end if; 8103 8104 -- When the instantiation occurs in a package declaration, append the 8105 -- freeze node to the private declarations (if any). 8106 8107 if Nkind (Par_N) = N_Package_Specification 8108 and then Decls = Visible_Declarations (Par_N) 8109 and then Present (Private_Declarations (Par_N)) 8110 and then not Is_Empty_List (Private_Declarations (Par_N)) 8111 then 8112 Decls := Private_Declarations (Par_N); 8113 Decl := First (Decls); 8114 end if; 8115 8116 -- Determine the proper freeze point of a package instantiation. We 8117 -- adhere to the general rule of a package or subprogram body causing 8118 -- freezing of anything before it in the same declarative region. In 8119 -- this case, the proper freeze point of a package instantiation is 8120 -- before the first source body which follows, or before a stub. This 8121 -- ensures that entities coming from the instance are already frozen 8122 -- and usable in source bodies. 8123 8124 if Nkind (Par_N) /= N_Package_Declaration 8125 and then Ekind (Inst) = E_Package 8126 and then Is_Generic_Instance (Inst) 8127 and then 8128 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 8129 then 8130 while Present (Decl) loop 8131 if (Nkind (Decl) in N_Unit_Body 8132 or else 8133 Nkind (Decl) in N_Body_Stub) 8134 and then Comes_From_Source (Decl) 8135 then 8136 Insert_Before (Decl, F_Node); 8137 return; 8138 end if; 8139 8140 Next (Decl); 8141 end loop; 8142 end if; 8143 8144 -- In a package declaration, or if no previous body, insert at end 8145 -- of list. 8146 8147 Set_Sloc (F_Node, Sloc (Last (Decls))); 8148 Insert_After (Last (Decls), F_Node); 8149 end if; 8150 end Insert_Freeze_Node_For_Instance; 8151 8152 ------------------ 8153 -- Install_Body -- 8154 ------------------ 8155 8156 procedure Install_Body 8157 (Act_Body : Node_Id; 8158 N : Node_Id; 8159 Gen_Body : Node_Id; 8160 Gen_Decl : Node_Id) 8161 is 8162 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 8163 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 8164 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 8165 Par : constant Entity_Id := Scope (Gen_Id); 8166 Gen_Unit : constant Node_Id := 8167 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 8168 Orig_Body : Node_Id := Gen_Body; 8169 F_Node : Node_Id; 8170 Body_Unit : Node_Id; 8171 8172 Must_Delay : Boolean; 8173 8174 function Enclosing_Subp (Id : Entity_Id) return Entity_Id; 8175 -- Find subprogram (if any) that encloses instance and/or generic body 8176 8177 function True_Sloc (N : Node_Id) return Source_Ptr; 8178 -- If the instance is nested inside a generic unit, the Sloc of the 8179 -- instance indicates the place of the original definition, not the 8180 -- point of the current enclosing instance. Pending a better usage of 8181 -- Slocs to indicate instantiation places, we determine the place of 8182 -- origin of a node by finding the maximum sloc of any ancestor node. 8183 -- Why is this not equivalent to Top_Level_Location ??? 8184 8185 -------------------- 8186 -- Enclosing_Subp -- 8187 -------------------- 8188 8189 function Enclosing_Subp (Id : Entity_Id) return Entity_Id is 8190 Scop : Entity_Id; 8191 8192 begin 8193 Scop := Scope (Id); 8194 while Scop /= Standard_Standard 8195 and then not Is_Overloadable (Scop) 8196 loop 8197 Scop := Scope (Scop); 8198 end loop; 8199 8200 return Scop; 8201 end Enclosing_Subp; 8202 8203 --------------- 8204 -- True_Sloc -- 8205 --------------- 8206 8207 function True_Sloc (N : Node_Id) return Source_Ptr is 8208 Res : Source_Ptr; 8209 N1 : Node_Id; 8210 8211 begin 8212 Res := Sloc (N); 8213 N1 := N; 8214 while Present (N1) and then N1 /= Act_Unit loop 8215 if Sloc (N1) > Res then 8216 Res := Sloc (N1); 8217 end if; 8218 8219 N1 := Parent (N1); 8220 end loop; 8221 8222 return Res; 8223 end True_Sloc; 8224 8225 -- Start of processing for Install_Body 8226 8227 begin 8228 -- If the body is a subunit, the freeze point is the corresponding stub 8229 -- in the current compilation, not the subunit itself. 8230 8231 if Nkind (Parent (Gen_Body)) = N_Subunit then 8232 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 8233 else 8234 Orig_Body := Gen_Body; 8235 end if; 8236 8237 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 8238 8239 -- If the instantiation and the generic definition appear in the same 8240 -- package declaration, this is an early instantiation. If they appear 8241 -- in the same declarative part, it is an early instantiation only if 8242 -- the generic body appears textually later, and the generic body is 8243 -- also in the main unit. 8244 8245 -- If instance is nested within a subprogram, and the generic body is 8246 -- not, the instance is delayed because the enclosing body is. If 8247 -- instance and body are within the same scope, or the same sub- 8248 -- program body, indicate explicitly that the instance is delayed. 8249 8250 Must_Delay := 8251 (Gen_Unit = Act_Unit 8252 and then (Nkind_In (Gen_Unit, N_Package_Declaration, 8253 N_Generic_Package_Declaration) 8254 or else (Gen_Unit = Body_Unit 8255 and then True_Sloc (N) < Sloc (Orig_Body))) 8256 and then Is_In_Main_Unit (Gen_Unit) 8257 and then (Scope (Act_Id) = Scope (Gen_Id) 8258 or else 8259 Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id))); 8260 8261 -- If this is an early instantiation, the freeze node is placed after 8262 -- the generic body. Otherwise, if the generic appears in an instance, 8263 -- we cannot freeze the current instance until the outer one is frozen. 8264 -- This is only relevant if the current instance is nested within some 8265 -- inner scope not itself within the outer instance. If this scope is 8266 -- a package body in the same declarative part as the outer instance, 8267 -- then that body needs to be frozen after the outer instance. Finally, 8268 -- if no delay is needed, we place the freeze node at the end of the 8269 -- current declarative part. 8270 8271 if Expander_Active then 8272 Ensure_Freeze_Node (Act_Id); 8273 F_Node := Freeze_Node (Act_Id); 8274 8275 if Must_Delay then 8276 Insert_After (Orig_Body, F_Node); 8277 8278 elsif Is_Generic_Instance (Par) 8279 and then Present (Freeze_Node (Par)) 8280 and then Scope (Act_Id) /= Par 8281 then 8282 -- Freeze instance of inner generic after instance of enclosing 8283 -- generic. 8284 8285 if In_Same_Declarative_Part (Freeze_Node (Par), N) then 8286 8287 -- Handle the following case: 8288 8289 -- package Parent_Inst is new ... 8290 -- Parent_Inst [] 8291 8292 -- procedure P ... -- this body freezes Parent_Inst 8293 8294 -- package Inst is new ... 8295 8296 -- In this particular scenario, the freeze node for Inst must 8297 -- be inserted in the same manner as that of Parent_Inst - 8298 -- before the next source body or at the end of the declarative 8299 -- list (body not available). If body P did not exist and 8300 -- Parent_Inst was frozen after Inst, either by a body 8301 -- following Inst or at the end of the declarative region, the 8302 -- freeze node for Inst must be inserted after that of 8303 -- Parent_Inst. This relation is established by comparing the 8304 -- Slocs of Parent_Inst freeze node and Inst. 8305 8306 if List_Containing (Get_Package_Instantiation_Node (Par)) = 8307 List_Containing (N) 8308 and then Sloc (Freeze_Node (Par)) < Sloc (N) 8309 then 8310 Insert_Freeze_Node_For_Instance (N, F_Node); 8311 else 8312 Insert_After (Freeze_Node (Par), F_Node); 8313 end if; 8314 8315 -- Freeze package enclosing instance of inner generic after 8316 -- instance of enclosing generic. 8317 8318 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 8319 and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) 8320 then 8321 declare 8322 Enclosing : Entity_Id; 8323 8324 begin 8325 Enclosing := Corresponding_Spec (Parent (N)); 8326 8327 if No (Enclosing) then 8328 Enclosing := Defining_Entity (Parent (N)); 8329 end if; 8330 8331 Insert_Freeze_Node_For_Instance (N, F_Node); 8332 Ensure_Freeze_Node (Enclosing); 8333 8334 if not Is_List_Member (Freeze_Node (Enclosing)) then 8335 8336 -- The enclosing context is a subunit, insert the freeze 8337 -- node after the stub. 8338 8339 if Nkind (Parent (Parent (N))) = N_Subunit then 8340 Insert_Freeze_Node_For_Instance 8341 (Corresponding_Stub (Parent (Parent (N))), 8342 Freeze_Node (Enclosing)); 8343 8344 -- The enclosing context is a package with a stub body 8345 -- which has already been replaced by the real body. 8346 -- Insert the freeze node after the actual body. 8347 8348 elsif Ekind (Enclosing) = E_Package 8349 and then Present (Body_Entity (Enclosing)) 8350 and then Was_Originally_Stub 8351 (Parent (Body_Entity (Enclosing))) 8352 then 8353 Insert_Freeze_Node_For_Instance 8354 (Parent (Body_Entity (Enclosing)), 8355 Freeze_Node (Enclosing)); 8356 8357 -- The parent instance has been frozen before the body of 8358 -- the enclosing package, insert the freeze node after 8359 -- the body. 8360 8361 elsif List_Containing (Freeze_Node (Par)) = 8362 List_Containing (Parent (N)) 8363 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 8364 then 8365 Insert_Freeze_Node_For_Instance 8366 (Parent (N), Freeze_Node (Enclosing)); 8367 8368 else 8369 Insert_After 8370 (Freeze_Node (Par), Freeze_Node (Enclosing)); 8371 end if; 8372 end if; 8373 end; 8374 8375 else 8376 Insert_Freeze_Node_For_Instance (N, F_Node); 8377 end if; 8378 8379 else 8380 Insert_Freeze_Node_For_Instance (N, F_Node); 8381 end if; 8382 end if; 8383 8384 Set_Is_Frozen (Act_Id); 8385 Insert_Before (N, Act_Body); 8386 Mark_Rewrite_Insertion (Act_Body); 8387 end Install_Body; 8388 8389 ----------------------------- 8390 -- Install_Formal_Packages -- 8391 ----------------------------- 8392 8393 procedure Install_Formal_Packages (Par : Entity_Id) is 8394 E : Entity_Id; 8395 Gen : Entity_Id; 8396 Gen_E : Entity_Id := Empty; 8397 8398 begin 8399 E := First_Entity (Par); 8400 8401 -- If we are installing an instance parent, locate the formal packages 8402 -- of its generic parent. 8403 8404 if Is_Generic_Instance (Par) then 8405 Gen := Generic_Parent (Package_Specification (Par)); 8406 Gen_E := First_Entity (Gen); 8407 end if; 8408 8409 while Present (E) loop 8410 if Ekind (E) = E_Package 8411 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 8412 then 8413 -- If this is the renaming for the parent instance, done 8414 8415 if Renamed_Object (E) = Par then 8416 exit; 8417 8418 -- The visibility of a formal of an enclosing generic is already 8419 -- correct. 8420 8421 elsif Denotes_Formal_Package (E) then 8422 null; 8423 8424 elsif Present (Associated_Formal_Package (E)) then 8425 Check_Generic_Actuals (Renamed_Object (E), True); 8426 Set_Is_Hidden (E, False); 8427 8428 -- Find formal package in generic unit that corresponds to 8429 -- (instance of) formal package in instance. 8430 8431 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 8432 Next_Entity (Gen_E); 8433 end loop; 8434 8435 if Present (Gen_E) then 8436 Map_Formal_Package_Entities (Gen_E, E); 8437 end if; 8438 end if; 8439 end if; 8440 8441 Next_Entity (E); 8442 if Present (Gen_E) then 8443 Next_Entity (Gen_E); 8444 end if; 8445 end loop; 8446 end Install_Formal_Packages; 8447 8448 -------------------- 8449 -- Install_Parent -- 8450 -------------------- 8451 8452 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 8453 Ancestors : constant Elist_Id := New_Elmt_List; 8454 S : constant Entity_Id := Current_Scope; 8455 Inst_Par : Entity_Id; 8456 First_Par : Entity_Id; 8457 Inst_Node : Node_Id; 8458 Gen_Par : Entity_Id; 8459 First_Gen : Entity_Id; 8460 Elmt : Elmt_Id; 8461 8462 procedure Install_Noninstance_Specs (Par : Entity_Id); 8463 -- Install the scopes of noninstance parent units ending with Par 8464 8465 procedure Install_Spec (Par : Entity_Id); 8466 -- The child unit is within the declarative part of the parent, so the 8467 -- declarations within the parent are immediately visible. 8468 8469 ------------------------------- 8470 -- Install_Noninstance_Specs -- 8471 ------------------------------- 8472 8473 procedure Install_Noninstance_Specs (Par : Entity_Id) is 8474 begin 8475 if Present (Par) 8476 and then Par /= Standard_Standard 8477 and then not In_Open_Scopes (Par) 8478 then 8479 Install_Noninstance_Specs (Scope (Par)); 8480 Install_Spec (Par); 8481 end if; 8482 end Install_Noninstance_Specs; 8483 8484 ------------------ 8485 -- Install_Spec -- 8486 ------------------ 8487 8488 procedure Install_Spec (Par : Entity_Id) is 8489 Spec : constant Node_Id := Package_Specification (Par); 8490 8491 begin 8492 -- If this parent of the child instance is a top-level unit, 8493 -- then record the unit and its visibility for later resetting in 8494 -- Remove_Parent. We exclude units that are generic instances, as we 8495 -- only want to record this information for the ultimate top-level 8496 -- noninstance parent (is that always correct???). 8497 8498 if Scope (Par) = Standard_Standard 8499 and then not Is_Generic_Instance (Par) 8500 then 8501 Parent_Unit_Visible := Is_Immediately_Visible (Par); 8502 Instance_Parent_Unit := Par; 8503 end if; 8504 8505 -- Open the parent scope and make it and its declarations visible. 8506 -- If this point is not within a body, then only the visible 8507 -- declarations should be made visible, and installation of the 8508 -- private declarations is deferred until the appropriate point 8509 -- within analysis of the spec being instantiated (see the handling 8510 -- of parent visibility in Analyze_Package_Specification). This is 8511 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 8512 -- private view problems that occur when compiling instantiations of 8513 -- a generic child of that package (Generic_Dispatching_Constructor). 8514 -- If the instance freezes a tagged type, inlinings of operations 8515 -- from Ada.Tags may need the full view of type Tag. If inlining took 8516 -- proper account of establishing visibility of inlined subprograms' 8517 -- parents then it should be possible to remove this 8518 -- special check. ??? 8519 8520 Push_Scope (Par); 8521 Set_Is_Immediately_Visible (Par); 8522 Install_Visible_Declarations (Par); 8523 Set_Use (Visible_Declarations (Spec)); 8524 8525 if In_Body or else Is_RTU (Par, Ada_Tags) then 8526 Install_Private_Declarations (Par); 8527 Set_Use (Private_Declarations (Spec)); 8528 end if; 8529 end Install_Spec; 8530 8531 -- Start of processing for Install_Parent 8532 8533 begin 8534 -- We need to install the parent instance to compile the instantiation 8535 -- of the child, but the child instance must appear in the current 8536 -- scope. Given that we cannot place the parent above the current scope 8537 -- in the scope stack, we duplicate the current scope and unstack both 8538 -- after the instantiation is complete. 8539 8540 -- If the parent is itself the instantiation of a child unit, we must 8541 -- also stack the instantiation of its parent, and so on. Each such 8542 -- ancestor is the prefix of the name in a prior instantiation. 8543 8544 -- If this is a nested instance, the parent unit itself resolves to 8545 -- a renaming of the parent instance, whose declaration we need. 8546 8547 -- Finally, the parent may be a generic (not an instance) when the 8548 -- child unit appears as a formal package. 8549 8550 Inst_Par := P; 8551 8552 if Present (Renamed_Entity (Inst_Par)) then 8553 Inst_Par := Renamed_Entity (Inst_Par); 8554 end if; 8555 8556 First_Par := Inst_Par; 8557 8558 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 8559 8560 First_Gen := Gen_Par; 8561 8562 while Present (Gen_Par) 8563 and then Is_Child_Unit (Gen_Par) 8564 loop 8565 -- Load grandparent instance as well 8566 8567 Inst_Node := Get_Package_Instantiation_Node (Inst_Par); 8568 8569 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 8570 Inst_Par := Entity (Prefix (Name (Inst_Node))); 8571 8572 if Present (Renamed_Entity (Inst_Par)) then 8573 Inst_Par := Renamed_Entity (Inst_Par); 8574 end if; 8575 8576 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 8577 8578 if Present (Gen_Par) then 8579 Prepend_Elmt (Inst_Par, Ancestors); 8580 8581 else 8582 -- Parent is not the name of an instantiation 8583 8584 Install_Noninstance_Specs (Inst_Par); 8585 exit; 8586 end if; 8587 8588 else 8589 -- Previous error 8590 8591 exit; 8592 end if; 8593 end loop; 8594 8595 if Present (First_Gen) then 8596 Append_Elmt (First_Par, Ancestors); 8597 else 8598 Install_Noninstance_Specs (First_Par); 8599 end if; 8600 8601 if not Is_Empty_Elmt_List (Ancestors) then 8602 Elmt := First_Elmt (Ancestors); 8603 while Present (Elmt) loop 8604 Install_Spec (Node (Elmt)); 8605 Install_Formal_Packages (Node (Elmt)); 8606 Next_Elmt (Elmt); 8607 end loop; 8608 end if; 8609 8610 if not In_Body then 8611 Push_Scope (S); 8612 end if; 8613 end Install_Parent; 8614 8615 ------------------------------- 8616 -- Install_Hidden_Primitives -- 8617 ------------------------------- 8618 8619 procedure Install_Hidden_Primitives 8620 (Prims_List : in out Elist_Id; 8621 Gen_T : Entity_Id; 8622 Act_T : Entity_Id) 8623 is 8624 Elmt : Elmt_Id; 8625 List : Elist_Id := No_Elist; 8626 Prim_G_Elmt : Elmt_Id; 8627 Prim_A_Elmt : Elmt_Id; 8628 Prim_G : Node_Id; 8629 Prim_A : Node_Id; 8630 8631 begin 8632 -- No action needed in case of serious errors because we cannot trust 8633 -- in the order of primitives 8634 8635 if Serious_Errors_Detected > 0 then 8636 return; 8637 8638 -- No action possible if we don't have available the list of primitive 8639 -- operations 8640 8641 elsif No (Gen_T) 8642 or else not Is_Record_Type (Gen_T) 8643 or else not Is_Tagged_Type (Gen_T) 8644 or else not Is_Record_Type (Act_T) 8645 or else not Is_Tagged_Type (Act_T) 8646 then 8647 return; 8648 8649 -- There is no need to handle interface types since their primitives 8650 -- cannot be hidden 8651 8652 elsif Is_Interface (Gen_T) then 8653 return; 8654 end if; 8655 8656 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 8657 8658 if not Is_Class_Wide_Type (Act_T) then 8659 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 8660 else 8661 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 8662 end if; 8663 8664 loop 8665 -- Skip predefined primitives in the generic formal 8666 8667 while Present (Prim_G_Elmt) 8668 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 8669 loop 8670 Next_Elmt (Prim_G_Elmt); 8671 end loop; 8672 8673 -- Skip predefined primitives in the generic actual 8674 8675 while Present (Prim_A_Elmt) 8676 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 8677 loop 8678 Next_Elmt (Prim_A_Elmt); 8679 end loop; 8680 8681 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 8682 8683 Prim_G := Node (Prim_G_Elmt); 8684 Prim_A := Node (Prim_A_Elmt); 8685 8686 -- There is no need to handle interface primitives because their 8687 -- primitives are not hidden 8688 8689 exit when Present (Interface_Alias (Prim_G)); 8690 8691 -- Here we install one hidden primitive 8692 8693 if Chars (Prim_G) /= Chars (Prim_A) 8694 and then Has_Suffix (Prim_A, 'P') 8695 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 8696 then 8697 Set_Chars (Prim_A, Chars (Prim_G)); 8698 8699 if List = No_Elist then 8700 List := New_Elmt_List; 8701 end if; 8702 8703 Append_Elmt (Prim_A, List); 8704 end if; 8705 8706 Next_Elmt (Prim_A_Elmt); 8707 Next_Elmt (Prim_G_Elmt); 8708 end loop; 8709 8710 -- Append the elements to the list of temporarily visible primitives 8711 -- avoiding duplicates. 8712 8713 if Present (List) then 8714 if No (Prims_List) then 8715 Prims_List := New_Elmt_List; 8716 end if; 8717 8718 Elmt := First_Elmt (List); 8719 while Present (Elmt) loop 8720 Append_Unique_Elmt (Node (Elmt), Prims_List); 8721 Next_Elmt (Elmt); 8722 end loop; 8723 end if; 8724 end Install_Hidden_Primitives; 8725 8726 ------------------------------- 8727 -- Restore_Hidden_Primitives -- 8728 ------------------------------- 8729 8730 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 8731 Prim_Elmt : Elmt_Id; 8732 Prim : Node_Id; 8733 8734 begin 8735 if Prims_List /= No_Elist then 8736 Prim_Elmt := First_Elmt (Prims_List); 8737 while Present (Prim_Elmt) loop 8738 Prim := Node (Prim_Elmt); 8739 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 8740 Next_Elmt (Prim_Elmt); 8741 end loop; 8742 8743 Prims_List := No_Elist; 8744 end if; 8745 end Restore_Hidden_Primitives; 8746 8747 -------------------------------- 8748 -- Instantiate_Formal_Package -- 8749 -------------------------------- 8750 8751 function Instantiate_Formal_Package 8752 (Formal : Node_Id; 8753 Actual : Node_Id; 8754 Analyzed_Formal : Node_Id) return List_Id 8755 is 8756 Loc : constant Source_Ptr := Sloc (Actual); 8757 Actual_Pack : Entity_Id; 8758 Formal_Pack : Entity_Id; 8759 Gen_Parent : Entity_Id; 8760 Decls : List_Id; 8761 Nod : Node_Id; 8762 Parent_Spec : Node_Id; 8763 8764 procedure Find_Matching_Actual 8765 (F : Node_Id; 8766 Act : in out Entity_Id); 8767 -- We need to associate each formal entity in the formal package with 8768 -- the corresponding entity in the actual package. The actual package 8769 -- has been analyzed and possibly expanded, and as a result there is 8770 -- no one-to-one correspondence between the two lists (for example, 8771 -- the actual may include subtypes, itypes, and inherited primitive 8772 -- operations, interspersed among the renaming declarations for the 8773 -- actuals) . We retrieve the corresponding actual by name because each 8774 -- actual has the same name as the formal, and they do appear in the 8775 -- same order. 8776 8777 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 8778 -- Retrieve entity of defining entity of generic formal parameter. 8779 -- Only the declarations of formals need to be considered when 8780 -- linking them to actuals, but the declarative list may include 8781 -- internal entities generated during analysis, and those are ignored. 8782 8783 procedure Match_Formal_Entity 8784 (Formal_Node : Node_Id; 8785 Formal_Ent : Entity_Id; 8786 Actual_Ent : Entity_Id); 8787 -- Associates the formal entity with the actual. In the case where 8788 -- Formal_Ent is a formal package, this procedure iterates through all 8789 -- of its formals and enters associations between the actuals occurring 8790 -- in the formal package's corresponding actual package (given by 8791 -- Actual_Ent) and the formal package's formal parameters. This 8792 -- procedure recurses if any of the parameters is itself a package. 8793 8794 function Is_Instance_Of 8795 (Act_Spec : Entity_Id; 8796 Gen_Anc : Entity_Id) return Boolean; 8797 -- The actual can be an instantiation of a generic within another 8798 -- instance, in which case there is no direct link from it to the 8799 -- original generic ancestor. In that case, we recognize that the 8800 -- ultimate ancestor is the same by examining names and scopes. 8801 8802 procedure Process_Nested_Formal (Formal : Entity_Id); 8803 -- If the current formal is declared with a box, its own formals are 8804 -- visible in the instance, as they were in the generic, and their 8805 -- Hidden flag must be reset. If some of these formals are themselves 8806 -- packages declared with a box, the processing must be recursive. 8807 8808 -------------------------- 8809 -- Find_Matching_Actual -- 8810 -------------------------- 8811 8812 procedure Find_Matching_Actual 8813 (F : Node_Id; 8814 Act : in out Entity_Id) 8815 is 8816 Formal_Ent : Entity_Id; 8817 8818 begin 8819 case Nkind (Original_Node (F)) is 8820 when N_Formal_Object_Declaration | 8821 N_Formal_Type_Declaration => 8822 Formal_Ent := Defining_Identifier (F); 8823 8824 while Chars (Act) /= Chars (Formal_Ent) loop 8825 Next_Entity (Act); 8826 end loop; 8827 8828 when N_Formal_Subprogram_Declaration | 8829 N_Formal_Package_Declaration | 8830 N_Package_Declaration | 8831 N_Generic_Package_Declaration => 8832 Formal_Ent := Defining_Entity (F); 8833 8834 while Chars (Act) /= Chars (Formal_Ent) loop 8835 Next_Entity (Act); 8836 end loop; 8837 8838 when others => 8839 raise Program_Error; 8840 end case; 8841 end Find_Matching_Actual; 8842 8843 ------------------------- 8844 -- Match_Formal_Entity -- 8845 ------------------------- 8846 8847 procedure Match_Formal_Entity 8848 (Formal_Node : Node_Id; 8849 Formal_Ent : Entity_Id; 8850 Actual_Ent : Entity_Id) 8851 is 8852 Act_Pkg : Entity_Id; 8853 8854 begin 8855 Set_Instance_Of (Formal_Ent, Actual_Ent); 8856 8857 if Ekind (Actual_Ent) = E_Package then 8858 8859 -- Record associations for each parameter 8860 8861 Act_Pkg := Actual_Ent; 8862 8863 declare 8864 A_Ent : Entity_Id := First_Entity (Act_Pkg); 8865 F_Ent : Entity_Id; 8866 F_Node : Node_Id; 8867 8868 Gen_Decl : Node_Id; 8869 Formals : List_Id; 8870 Actual : Entity_Id; 8871 8872 begin 8873 -- Retrieve the actual given in the formal package declaration 8874 8875 Actual := Entity (Name (Original_Node (Formal_Node))); 8876 8877 -- The actual in the formal package declaration may be a 8878 -- renamed generic package, in which case we want to retrieve 8879 -- the original generic in order to traverse its formal part. 8880 8881 if Present (Renamed_Entity (Actual)) then 8882 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 8883 else 8884 Gen_Decl := Unit_Declaration_Node (Actual); 8885 end if; 8886 8887 Formals := Generic_Formal_Declarations (Gen_Decl); 8888 8889 if Present (Formals) then 8890 F_Node := First_Non_Pragma (Formals); 8891 else 8892 F_Node := Empty; 8893 end if; 8894 8895 while Present (A_Ent) 8896 and then Present (F_Node) 8897 and then A_Ent /= First_Private_Entity (Act_Pkg) 8898 loop 8899 F_Ent := Get_Formal_Entity (F_Node); 8900 8901 if Present (F_Ent) then 8902 8903 -- This is a formal of the original package. Record 8904 -- association and recurse. 8905 8906 Find_Matching_Actual (F_Node, A_Ent); 8907 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 8908 Next_Entity (A_Ent); 8909 end if; 8910 8911 Next_Non_Pragma (F_Node); 8912 end loop; 8913 end; 8914 end if; 8915 end Match_Formal_Entity; 8916 8917 ----------------------- 8918 -- Get_Formal_Entity -- 8919 ----------------------- 8920 8921 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 8922 Kind : constant Node_Kind := Nkind (Original_Node (N)); 8923 begin 8924 case Kind is 8925 when N_Formal_Object_Declaration => 8926 return Defining_Identifier (N); 8927 8928 when N_Formal_Type_Declaration => 8929 return Defining_Identifier (N); 8930 8931 when N_Formal_Subprogram_Declaration => 8932 return Defining_Unit_Name (Specification (N)); 8933 8934 when N_Formal_Package_Declaration => 8935 return Defining_Identifier (Original_Node (N)); 8936 8937 when N_Generic_Package_Declaration => 8938 return Defining_Identifier (Original_Node (N)); 8939 8940 -- All other declarations are introduced by semantic analysis and 8941 -- have no match in the actual. 8942 8943 when others => 8944 return Empty; 8945 end case; 8946 end Get_Formal_Entity; 8947 8948 -------------------- 8949 -- Is_Instance_Of -- 8950 -------------------- 8951 8952 function Is_Instance_Of 8953 (Act_Spec : Entity_Id; 8954 Gen_Anc : Entity_Id) return Boolean 8955 is 8956 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 8957 8958 begin 8959 if No (Gen_Par) then 8960 return False; 8961 8962 -- Simplest case: the generic parent of the actual is the formal 8963 8964 elsif Gen_Par = Gen_Anc then 8965 return True; 8966 8967 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 8968 return False; 8969 8970 -- The actual may be obtained through several instantiations. Its 8971 -- scope must itself be an instance of a generic declared in the 8972 -- same scope as the formal. Any other case is detected above. 8973 8974 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 8975 return False; 8976 8977 else 8978 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 8979 end if; 8980 end Is_Instance_Of; 8981 8982 --------------------------- 8983 -- Process_Nested_Formal -- 8984 --------------------------- 8985 8986 procedure Process_Nested_Formal (Formal : Entity_Id) is 8987 Ent : Entity_Id; 8988 8989 begin 8990 if Present (Associated_Formal_Package (Formal)) 8991 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 8992 then 8993 Ent := First_Entity (Formal); 8994 while Present (Ent) loop 8995 Set_Is_Hidden (Ent, False); 8996 Set_Is_Visible_Formal (Ent); 8997 Set_Is_Potentially_Use_Visible 8998 (Ent, Is_Potentially_Use_Visible (Formal)); 8999 9000 if Ekind (Ent) = E_Package then 9001 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 9002 Process_Nested_Formal (Ent); 9003 end if; 9004 9005 Next_Entity (Ent); 9006 end loop; 9007 end if; 9008 end Process_Nested_Formal; 9009 9010 -- Start of processing for Instantiate_Formal_Package 9011 9012 begin 9013 Analyze (Actual); 9014 9015 if not Is_Entity_Name (Actual) 9016 or else Ekind (Entity (Actual)) /= E_Package 9017 then 9018 Error_Msg_N 9019 ("expect package instance to instantiate formal", Actual); 9020 Abandon_Instantiation (Actual); 9021 raise Program_Error; 9022 9023 else 9024 Actual_Pack := Entity (Actual); 9025 Set_Is_Instantiated (Actual_Pack); 9026 9027 -- The actual may be a renamed package, or an outer generic formal 9028 -- package whose instantiation is converted into a renaming. 9029 9030 if Present (Renamed_Object (Actual_Pack)) then 9031 Actual_Pack := Renamed_Object (Actual_Pack); 9032 end if; 9033 9034 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 9035 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 9036 Formal_Pack := Defining_Identifier (Analyzed_Formal); 9037 else 9038 Gen_Parent := 9039 Generic_Parent (Specification (Analyzed_Formal)); 9040 Formal_Pack := 9041 Defining_Unit_Name (Specification (Analyzed_Formal)); 9042 end if; 9043 9044 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 9045 Parent_Spec := Package_Specification (Actual_Pack); 9046 else 9047 Parent_Spec := Parent (Actual_Pack); 9048 end if; 9049 9050 if Gen_Parent = Any_Id then 9051 Error_Msg_N 9052 ("previous error in declaration of formal package", Actual); 9053 Abandon_Instantiation (Actual); 9054 9055 elsif 9056 Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) 9057 then 9058 null; 9059 9060 else 9061 Error_Msg_NE 9062 ("actual parameter must be instance of&", Actual, Gen_Parent); 9063 Abandon_Instantiation (Actual); 9064 end if; 9065 9066 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 9067 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 9068 9069 Nod := 9070 Make_Package_Renaming_Declaration (Loc, 9071 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 9072 Name => New_Occurrence_Of (Actual_Pack, Loc)); 9073 9074 Set_Associated_Formal_Package (Defining_Unit_Name (Nod), 9075 Defining_Identifier (Formal)); 9076 Decls := New_List (Nod); 9077 9078 -- If the formal F has a box, then the generic declarations are 9079 -- visible in the generic G. In an instance of G, the corresponding 9080 -- entities in the actual for F (which are the actuals for the 9081 -- instantiation of the generic that F denotes) must also be made 9082 -- visible for analysis of the current instance. On exit from the 9083 -- current instance, those entities are made private again. If the 9084 -- actual is currently in use, these entities are also use-visible. 9085 9086 -- The loop through the actual entities also steps through the formal 9087 -- entities and enters associations from formals to actuals into the 9088 -- renaming map. This is necessary to properly handle checking of 9089 -- actual parameter associations for later formals that depend on 9090 -- actuals declared in the formal package. 9091 9092 -- In Ada 2005, partial parameterization requires that we make 9093 -- visible the actuals corresponding to formals that were defaulted 9094 -- in the formal package. There formals are identified because they 9095 -- remain formal generics within the formal package, rather than 9096 -- being renamings of the actuals supplied. 9097 9098 declare 9099 Gen_Decl : constant Node_Id := 9100 Unit_Declaration_Node (Gen_Parent); 9101 Formals : constant List_Id := 9102 Generic_Formal_Declarations (Gen_Decl); 9103 9104 Actual_Ent : Entity_Id; 9105 Actual_Of_Formal : Node_Id; 9106 Formal_Node : Node_Id; 9107 Formal_Ent : Entity_Id; 9108 9109 begin 9110 if Present (Formals) then 9111 Formal_Node := First_Non_Pragma (Formals); 9112 else 9113 Formal_Node := Empty; 9114 end if; 9115 9116 Actual_Ent := First_Entity (Actual_Pack); 9117 Actual_Of_Formal := 9118 First (Visible_Declarations (Specification (Analyzed_Formal))); 9119 while Present (Actual_Ent) 9120 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9121 loop 9122 if Present (Formal_Node) then 9123 Formal_Ent := Get_Formal_Entity (Formal_Node); 9124 9125 if Present (Formal_Ent) then 9126 Find_Matching_Actual (Formal_Node, Actual_Ent); 9127 Match_Formal_Entity 9128 (Formal_Node, Formal_Ent, Actual_Ent); 9129 9130 -- We iterate at the same time over the actuals of the 9131 -- local package created for the formal, to determine 9132 -- which one of the formals of the original generic were 9133 -- defaulted in the formal. The corresponding actual 9134 -- entities are visible in the enclosing instance. 9135 9136 if Box_Present (Formal) 9137 or else 9138 (Present (Actual_Of_Formal) 9139 and then 9140 Is_Generic_Formal 9141 (Get_Formal_Entity (Actual_Of_Formal))) 9142 then 9143 Set_Is_Hidden (Actual_Ent, False); 9144 Set_Is_Visible_Formal (Actual_Ent); 9145 Set_Is_Potentially_Use_Visible 9146 (Actual_Ent, In_Use (Actual_Pack)); 9147 9148 if Ekind (Actual_Ent) = E_Package then 9149 Process_Nested_Formal (Actual_Ent); 9150 end if; 9151 9152 else 9153 Set_Is_Hidden (Actual_Ent); 9154 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 9155 end if; 9156 end if; 9157 9158 Next_Non_Pragma (Formal_Node); 9159 Next (Actual_Of_Formal); 9160 9161 else 9162 -- No further formals to match, but the generic part may 9163 -- contain inherited operation that are not hidden in the 9164 -- enclosing instance. 9165 9166 Next_Entity (Actual_Ent); 9167 end if; 9168 end loop; 9169 9170 -- Inherited subprograms generated by formal derived types are 9171 -- also visible if the types are. 9172 9173 Actual_Ent := First_Entity (Actual_Pack); 9174 while Present (Actual_Ent) 9175 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 9176 loop 9177 if Is_Overloadable (Actual_Ent) 9178 and then 9179 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 9180 and then 9181 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 9182 then 9183 Set_Is_Hidden (Actual_Ent, False); 9184 Set_Is_Potentially_Use_Visible 9185 (Actual_Ent, In_Use (Actual_Pack)); 9186 end if; 9187 9188 Next_Entity (Actual_Ent); 9189 end loop; 9190 end; 9191 9192 -- If the formal is not declared with a box, reanalyze it as an 9193 -- abbreviated instantiation, to verify the matching rules of 12.7. 9194 -- The actual checks are performed after the generic associations 9195 -- have been analyzed, to guarantee the same visibility for this 9196 -- instantiation and for the actuals. 9197 9198 -- In Ada 2005, the generic associations for the formal can include 9199 -- defaulted parameters. These are ignored during check. This 9200 -- internal instantiation is removed from the tree after conformance 9201 -- checking, because it contains formal declarations for those 9202 -- defaulted parameters, and those should not reach the back-end. 9203 9204 if not Box_Present (Formal) then 9205 declare 9206 I_Pack : constant Entity_Id := 9207 Make_Temporary (Sloc (Actual), 'P'); 9208 9209 begin 9210 Set_Is_Internal (I_Pack); 9211 9212 Append_To (Decls, 9213 Make_Package_Instantiation (Sloc (Actual), 9214 Defining_Unit_Name => I_Pack, 9215 Name => 9216 New_Occurrence_Of 9217 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 9218 Generic_Associations => 9219 Generic_Associations (Formal))); 9220 end; 9221 end if; 9222 9223 return Decls; 9224 end if; 9225 end Instantiate_Formal_Package; 9226 9227 ----------------------------------- 9228 -- Instantiate_Formal_Subprogram -- 9229 ----------------------------------- 9230 9231 function Instantiate_Formal_Subprogram 9232 (Formal : Node_Id; 9233 Actual : Node_Id; 9234 Analyzed_Formal : Node_Id) return Node_Id 9235 is 9236 Loc : Source_Ptr; 9237 Formal_Sub : constant Entity_Id := 9238 Defining_Unit_Name (Specification (Formal)); 9239 Analyzed_S : constant Entity_Id := 9240 Defining_Unit_Name (Specification (Analyzed_Formal)); 9241 Decl_Node : Node_Id; 9242 Nam : Node_Id; 9243 New_Spec : Node_Id; 9244 9245 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 9246 -- If the generic is a child unit, the parent has been installed on the 9247 -- scope stack, but a default subprogram cannot resolve to something 9248 -- on the parent because that parent is not really part of the visible 9249 -- context (it is there to resolve explicit local entities). If the 9250 -- default has resolved in this way, we remove the entity from immediate 9251 -- visibility and analyze the node again to emit an error message or 9252 -- find another visible candidate. 9253 9254 procedure Valid_Actual_Subprogram (Act : Node_Id); 9255 -- Perform legality check and raise exception on failure 9256 9257 ----------------------- 9258 -- From_Parent_Scope -- 9259 ----------------------- 9260 9261 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 9262 Gen_Scope : Node_Id; 9263 9264 begin 9265 Gen_Scope := Scope (Analyzed_S); 9266 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 9267 if Scope (Subp) = Scope (Gen_Scope) then 9268 return True; 9269 end if; 9270 9271 Gen_Scope := Scope (Gen_Scope); 9272 end loop; 9273 9274 return False; 9275 end From_Parent_Scope; 9276 9277 ----------------------------- 9278 -- Valid_Actual_Subprogram -- 9279 ----------------------------- 9280 9281 procedure Valid_Actual_Subprogram (Act : Node_Id) is 9282 Act_E : Entity_Id; 9283 9284 begin 9285 if Is_Entity_Name (Act) then 9286 Act_E := Entity (Act); 9287 9288 elsif Nkind (Act) = N_Selected_Component 9289 and then Is_Entity_Name (Selector_Name (Act)) 9290 then 9291 Act_E := Entity (Selector_Name (Act)); 9292 9293 else 9294 Act_E := Empty; 9295 end if; 9296 9297 if (Present (Act_E) and then Is_Overloadable (Act_E)) 9298 or else Nkind_In (Act, N_Attribute_Reference, 9299 N_Indexed_Component, 9300 N_Character_Literal, 9301 N_Explicit_Dereference) 9302 then 9303 return; 9304 end if; 9305 9306 Error_Msg_NE 9307 ("expect subprogram or entry name in instantiation of&", 9308 Instantiation_Node, Formal_Sub); 9309 Abandon_Instantiation (Instantiation_Node); 9310 9311 end Valid_Actual_Subprogram; 9312 9313 -- Start of processing for Instantiate_Formal_Subprogram 9314 9315 begin 9316 New_Spec := New_Copy_Tree (Specification (Formal)); 9317 9318 -- The tree copy has created the proper instantiation sloc for the 9319 -- new specification. Use this location for all other constructed 9320 -- declarations. 9321 9322 Loc := Sloc (Defining_Unit_Name (New_Spec)); 9323 9324 -- Create new entity for the actual (New_Copy_Tree does not) 9325 9326 Set_Defining_Unit_Name 9327 (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 9328 9329 -- Create new entities for the each of the formals in the 9330 -- specification of the renaming declaration built for the actual. 9331 9332 if Present (Parameter_Specifications (New_Spec)) then 9333 declare 9334 F : Node_Id; 9335 begin 9336 F := First (Parameter_Specifications (New_Spec)); 9337 while Present (F) loop 9338 Set_Defining_Identifier (F, 9339 Make_Defining_Identifier (Sloc (F), 9340 Chars => Chars (Defining_Identifier (F)))); 9341 Next (F); 9342 end loop; 9343 end; 9344 end if; 9345 9346 -- Find entity of actual. If the actual is an attribute reference, it 9347 -- cannot be resolved here (its formal is missing) but is handled 9348 -- instead in Attribute_Renaming. If the actual is overloaded, it is 9349 -- fully resolved subsequently, when the renaming declaration for the 9350 -- formal is analyzed. If it is an explicit dereference, resolve the 9351 -- prefix but not the actual itself, to prevent interpretation as call. 9352 9353 if Present (Actual) then 9354 Loc := Sloc (Actual); 9355 Set_Sloc (New_Spec, Loc); 9356 9357 if Nkind (Actual) = N_Operator_Symbol then 9358 Find_Direct_Name (Actual); 9359 9360 elsif Nkind (Actual) = N_Explicit_Dereference then 9361 Analyze (Prefix (Actual)); 9362 9363 elsif Nkind (Actual) /= N_Attribute_Reference then 9364 Analyze (Actual); 9365 end if; 9366 9367 Valid_Actual_Subprogram (Actual); 9368 Nam := Actual; 9369 9370 elsif Present (Default_Name (Formal)) then 9371 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 9372 N_Selected_Component, 9373 N_Indexed_Component, 9374 N_Character_Literal) 9375 and then Present (Entity (Default_Name (Formal))) 9376 then 9377 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 9378 else 9379 Nam := New_Copy (Default_Name (Formal)); 9380 Set_Sloc (Nam, Loc); 9381 end if; 9382 9383 elsif Box_Present (Formal) then 9384 9385 -- Actual is resolved at the point of instantiation. Create an 9386 -- identifier or operator with the same name as the formal. 9387 9388 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 9389 Nam := Make_Operator_Symbol (Loc, 9390 Chars => Chars (Formal_Sub), 9391 Strval => No_String); 9392 else 9393 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 9394 end if; 9395 9396 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 9397 and then Null_Present (Specification (Formal)) 9398 then 9399 -- Generate null body for procedure, for use in the instance 9400 9401 Decl_Node := 9402 Make_Subprogram_Body (Loc, 9403 Specification => New_Spec, 9404 Declarations => New_List, 9405 Handled_Statement_Sequence => 9406 Make_Handled_Sequence_Of_Statements (Loc, 9407 Statements => New_List (Make_Null_Statement (Loc)))); 9408 9409 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 9410 return Decl_Node; 9411 9412 else 9413 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 9414 Error_Msg_NE 9415 ("missing actual&", Instantiation_Node, Formal_Sub); 9416 Error_Msg_NE 9417 ("\in instantiation of & declared#", 9418 Instantiation_Node, Scope (Analyzed_S)); 9419 Abandon_Instantiation (Instantiation_Node); 9420 end if; 9421 9422 Decl_Node := 9423 Make_Subprogram_Renaming_Declaration (Loc, 9424 Specification => New_Spec, 9425 Name => Nam); 9426 9427 -- If we do not have an actual and the formal specified <> then set to 9428 -- get proper default. 9429 9430 if No (Actual) and then Box_Present (Formal) then 9431 Set_From_Default (Decl_Node); 9432 end if; 9433 9434 -- Gather possible interpretations for the actual before analyzing the 9435 -- instance. If overloaded, it will be resolved when analyzing the 9436 -- renaming declaration. 9437 9438 if Box_Present (Formal) 9439 and then No (Actual) 9440 then 9441 Analyze (Nam); 9442 9443 if Is_Child_Unit (Scope (Analyzed_S)) 9444 and then Present (Entity (Nam)) 9445 then 9446 if not Is_Overloaded (Nam) then 9447 if From_Parent_Scope (Entity (Nam)) then 9448 Set_Is_Immediately_Visible (Entity (Nam), False); 9449 Set_Entity (Nam, Empty); 9450 Set_Etype (Nam, Empty); 9451 9452 Analyze (Nam); 9453 Set_Is_Immediately_Visible (Entity (Nam)); 9454 end if; 9455 9456 else 9457 declare 9458 I : Interp_Index; 9459 It : Interp; 9460 9461 begin 9462 Get_First_Interp (Nam, I, It); 9463 while Present (It.Nam) loop 9464 if From_Parent_Scope (It.Nam) then 9465 Remove_Interp (I); 9466 end if; 9467 9468 Get_Next_Interp (I, It); 9469 end loop; 9470 end; 9471 end if; 9472 end if; 9473 end if; 9474 9475 -- The generic instantiation freezes the actual. This can only be done 9476 -- once the actual is resolved, in the analysis of the renaming 9477 -- declaration. To make the formal subprogram entity available, we set 9478 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 9479 -- This is also needed in Analyze_Subprogram_Renaming for the processing 9480 -- of formal abstract subprograms. 9481 9482 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 9483 9484 -- We cannot analyze the renaming declaration, and thus find the actual, 9485 -- until all the actuals are assembled in the instance. For subsequent 9486 -- checks of other actuals, indicate the node that will hold the 9487 -- instance of this formal. 9488 9489 Set_Instance_Of (Analyzed_S, Nam); 9490 9491 if Nkind (Actual) = N_Selected_Component 9492 and then Is_Task_Type (Etype (Prefix (Actual))) 9493 and then not Is_Frozen (Etype (Prefix (Actual))) 9494 then 9495 -- The renaming declaration will create a body, which must appear 9496 -- outside of the instantiation, We move the renaming declaration 9497 -- out of the instance, and create an additional renaming inside, 9498 -- to prevent freezing anomalies. 9499 9500 declare 9501 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 9502 9503 begin 9504 Set_Defining_Unit_Name (New_Spec, Anon_Id); 9505 Insert_Before (Instantiation_Node, Decl_Node); 9506 Analyze (Decl_Node); 9507 9508 -- Now create renaming within the instance 9509 9510 Decl_Node := 9511 Make_Subprogram_Renaming_Declaration (Loc, 9512 Specification => New_Copy_Tree (New_Spec), 9513 Name => New_Occurrence_Of (Anon_Id, Loc)); 9514 9515 Set_Defining_Unit_Name (Specification (Decl_Node), 9516 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 9517 end; 9518 end if; 9519 9520 return Decl_Node; 9521 end Instantiate_Formal_Subprogram; 9522 9523 ------------------------ 9524 -- Instantiate_Object -- 9525 ------------------------ 9526 9527 function Instantiate_Object 9528 (Formal : Node_Id; 9529 Actual : Node_Id; 9530 Analyzed_Formal : Node_Id) return List_Id 9531 is 9532 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 9533 A_Gen_Obj : constant Entity_Id := 9534 Defining_Identifier (Analyzed_Formal); 9535 Acc_Def : Node_Id := Empty; 9536 Act_Assoc : constant Node_Id := Parent (Actual); 9537 Actual_Decl : Node_Id := Empty; 9538 Decl_Node : Node_Id; 9539 Def : Node_Id; 9540 Ftyp : Entity_Id; 9541 List : constant List_Id := New_List; 9542 Loc : constant Source_Ptr := Sloc (Actual); 9543 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 9544 Subt_Decl : Node_Id := Empty; 9545 Subt_Mark : Node_Id := Empty; 9546 9547 begin 9548 if Present (Subtype_Mark (Formal)) then 9549 Subt_Mark := Subtype_Mark (Formal); 9550 else 9551 Check_Access_Definition (Formal); 9552 Acc_Def := Access_Definition (Formal); 9553 end if; 9554 9555 -- Sloc for error message on missing actual 9556 9557 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 9558 9559 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 9560 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 9561 end if; 9562 9563 Set_Parent (List, Parent (Actual)); 9564 9565 -- OUT present 9566 9567 if Out_Present (Formal) then 9568 9569 -- An IN OUT generic actual must be a name. The instantiation is a 9570 -- renaming declaration. The actual is the name being renamed. We 9571 -- use the actual directly, rather than a copy, because it is not 9572 -- used further in the list of actuals, and because a copy or a use 9573 -- of relocate_node is incorrect if the instance is nested within a 9574 -- generic. In order to simplify ASIS searches, the Generic_Parent 9575 -- field links the declaration to the generic association. 9576 9577 if No (Actual) then 9578 Error_Msg_NE 9579 ("missing actual&", 9580 Instantiation_Node, Gen_Obj); 9581 Error_Msg_NE 9582 ("\in instantiation of & declared#", 9583 Instantiation_Node, Scope (A_Gen_Obj)); 9584 Abandon_Instantiation (Instantiation_Node); 9585 end if; 9586 9587 if Present (Subt_Mark) then 9588 Decl_Node := 9589 Make_Object_Renaming_Declaration (Loc, 9590 Defining_Identifier => New_Copy (Gen_Obj), 9591 Subtype_Mark => New_Copy_Tree (Subt_Mark), 9592 Name => Actual); 9593 9594 else pragma Assert (Present (Acc_Def)); 9595 Decl_Node := 9596 Make_Object_Renaming_Declaration (Loc, 9597 Defining_Identifier => New_Copy (Gen_Obj), 9598 Access_Definition => New_Copy_Tree (Acc_Def), 9599 Name => Actual); 9600 end if; 9601 9602 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 9603 9604 -- The analysis of the actual may produce Insert_Action nodes, so 9605 -- the declaration must have a context in which to attach them. 9606 9607 Append (Decl_Node, List); 9608 Analyze (Actual); 9609 9610 -- Return if the analysis of the actual reported some error 9611 9612 if Etype (Actual) = Any_Type then 9613 return List; 9614 end if; 9615 9616 -- This check is performed here because Analyze_Object_Renaming will 9617 -- not check it when Comes_From_Source is False. Note though that the 9618 -- check for the actual being the name of an object will be performed 9619 -- in Analyze_Object_Renaming. 9620 9621 if Is_Object_Reference (Actual) 9622 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 9623 then 9624 Error_Msg_N 9625 ("illegal discriminant-dependent component for in out parameter", 9626 Actual); 9627 end if; 9628 9629 -- The actual has to be resolved in order to check that it is a 9630 -- variable (due to cases such as F (1), where F returns access to 9631 -- an array, and for overloaded prefixes). 9632 9633 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 9634 9635 -- If the type of the formal is not itself a formal, and the current 9636 -- unit is a child unit, the formal type must be declared in a 9637 -- parent, and must be retrieved by visibility. 9638 9639 if Ftyp = Orig_Ftyp 9640 and then Is_Generic_Unit (Scope (Ftyp)) 9641 and then Is_Child_Unit (Scope (A_Gen_Obj)) 9642 then 9643 declare 9644 Temp : constant Node_Id := 9645 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 9646 begin 9647 Set_Entity (Temp, Empty); 9648 Find_Type (Temp); 9649 Ftyp := Entity (Temp); 9650 end; 9651 end if; 9652 9653 if Is_Private_Type (Ftyp) 9654 and then not Is_Private_Type (Etype (Actual)) 9655 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 9656 or else Base_Type (Etype (Actual)) = Ftyp) 9657 then 9658 -- If the actual has the type of the full view of the formal, or 9659 -- else a non-private subtype of the formal, then the visibility 9660 -- of the formal type has changed. Add to the actuals a subtype 9661 -- declaration that will force the exchange of views in the body 9662 -- of the instance as well. 9663 9664 Subt_Decl := 9665 Make_Subtype_Declaration (Loc, 9666 Defining_Identifier => Make_Temporary (Loc, 'P'), 9667 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 9668 9669 Prepend (Subt_Decl, List); 9670 9671 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 9672 Exchange_Declarations (Ftyp); 9673 end if; 9674 9675 Resolve (Actual, Ftyp); 9676 9677 if not Denotes_Variable (Actual) then 9678 Error_Msg_NE 9679 ("actual for& must be a variable", Actual, Gen_Obj); 9680 9681 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 9682 9683 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 9684 -- the type of the actual shall resolve to a specific anonymous 9685 -- access type. 9686 9687 if Ada_Version < Ada_2005 9688 or else 9689 Ekind (Base_Type (Ftyp)) /= 9690 E_Anonymous_Access_Type 9691 or else 9692 Ekind (Base_Type (Etype (Actual))) /= 9693 E_Anonymous_Access_Type 9694 then 9695 Error_Msg_NE ("type of actual does not match type of&", 9696 Actual, Gen_Obj); 9697 end if; 9698 end if; 9699 9700 Note_Possible_Modification (Actual, Sure => True); 9701 9702 -- Check for instantiation of atomic/volatile actual for 9703 -- non-atomic/volatile formal (RM C.6 (12)). 9704 9705 if Is_Atomic_Object (Actual) 9706 and then not Is_Atomic (Orig_Ftyp) 9707 then 9708 Error_Msg_N 9709 ("cannot instantiate non-atomic formal object " & 9710 "with atomic actual", Actual); 9711 9712 elsif Is_Volatile_Object (Actual) 9713 and then not Is_Volatile (Orig_Ftyp) 9714 then 9715 Error_Msg_N 9716 ("cannot instantiate non-volatile formal object " & 9717 "with volatile actual", Actual); 9718 end if; 9719 9720 -- Formal in-parameter 9721 9722 else 9723 -- The instantiation of a generic formal in-parameter is constant 9724 -- declaration. The actual is the expression for that declaration. 9725 9726 if Present (Actual) then 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 (Loc, 9735 Defining_Identifier => New_Copy (Gen_Obj), 9736 Constant_Present => True, 9737 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9738 Object_Definition => New_Copy_Tree (Def), 9739 Expression => Actual); 9740 9741 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 9742 9743 -- A generic formal object of a tagged type is defined to be 9744 -- aliased so the new constant must also be treated as aliased. 9745 9746 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 9747 Set_Aliased_Present (Decl_Node); 9748 end if; 9749 9750 Append (Decl_Node, List); 9751 9752 -- No need to repeat (pre-)analysis of some expression nodes 9753 -- already handled in Preanalyze_Actuals. 9754 9755 if Nkind (Actual) /= N_Allocator then 9756 Analyze (Actual); 9757 9758 -- Return if the analysis of the actual reported some error 9759 9760 if Etype (Actual) = Any_Type then 9761 return List; 9762 end if; 9763 end if; 9764 9765 declare 9766 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 9767 Typ : Entity_Id; 9768 9769 begin 9770 Typ := Get_Instance_Of (Formal_Type); 9771 9772 Freeze_Before (Instantiation_Node, Typ); 9773 9774 -- If the actual is an aggregate, perform name resolution on 9775 -- its components (the analysis of an aggregate does not do it) 9776 -- to capture local names that may be hidden if the generic is 9777 -- a child unit. 9778 9779 if Nkind (Actual) = N_Aggregate then 9780 Preanalyze_And_Resolve (Actual, Typ); 9781 end if; 9782 9783 if Is_Limited_Type (Typ) 9784 and then not OK_For_Limited_Init (Typ, Actual) 9785 then 9786 Error_Msg_N 9787 ("initialization not allowed for limited types", Actual); 9788 Explain_Limited_Type (Typ, Actual); 9789 end if; 9790 end; 9791 9792 elsif Present (Default_Expression (Formal)) then 9793 9794 -- Use default to construct declaration 9795 9796 if Present (Subt_Mark) then 9797 Def := Subt_Mark; 9798 else pragma Assert (Present (Acc_Def)); 9799 Def := Acc_Def; 9800 end if; 9801 9802 Decl_Node := 9803 Make_Object_Declaration (Sloc (Formal), 9804 Defining_Identifier => New_Copy (Gen_Obj), 9805 Constant_Present => True, 9806 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9807 Object_Definition => New_Copy (Def), 9808 Expression => New_Copy_Tree 9809 (Default_Expression (Formal))); 9810 9811 Append (Decl_Node, List); 9812 Set_Analyzed (Expression (Decl_Node), False); 9813 9814 else 9815 Error_Msg_NE 9816 ("missing actual&", 9817 Instantiation_Node, Gen_Obj); 9818 Error_Msg_NE ("\in instantiation of & declared#", 9819 Instantiation_Node, Scope (A_Gen_Obj)); 9820 9821 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 9822 9823 -- Create dummy constant declaration so that instance can be 9824 -- analyzed, to minimize cascaded visibility errors. 9825 9826 if Present (Subt_Mark) then 9827 Def := Subt_Mark; 9828 else pragma Assert (Present (Acc_Def)); 9829 Def := Acc_Def; 9830 end if; 9831 9832 Decl_Node := 9833 Make_Object_Declaration (Loc, 9834 Defining_Identifier => New_Copy (Gen_Obj), 9835 Constant_Present => True, 9836 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 9837 Object_Definition => New_Copy (Def), 9838 Expression => 9839 Make_Attribute_Reference (Sloc (Gen_Obj), 9840 Attribute_Name => Name_First, 9841 Prefix => New_Copy (Def))); 9842 9843 Append (Decl_Node, List); 9844 9845 else 9846 Abandon_Instantiation (Instantiation_Node); 9847 end if; 9848 end if; 9849 end if; 9850 9851 if Nkind (Actual) in N_Has_Entity then 9852 Actual_Decl := Parent (Entity (Actual)); 9853 end if; 9854 9855 -- Ada 2005 (AI-423): For a formal object declaration with a null 9856 -- exclusion or an access definition that has a null exclusion: If the 9857 -- actual matching the formal object declaration denotes a generic 9858 -- formal object of another generic unit G, and the instantiation 9859 -- containing the actual occurs within the body of G or within the body 9860 -- of a generic unit declared within the declarative region of G, then 9861 -- the declaration of the formal object of G must have a null exclusion. 9862 -- Otherwise, the subtype of the actual matching the formal object 9863 -- declaration shall exclude null. 9864 9865 if Ada_Version >= Ada_2005 9866 and then Present (Actual_Decl) 9867 and then 9868 Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 9869 N_Object_Declaration) 9870 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 9871 and then not Has_Null_Exclusion (Actual_Decl) 9872 and then Has_Null_Exclusion (Analyzed_Formal) 9873 then 9874 Error_Msg_Sloc := Sloc (Analyzed_Formal); 9875 Error_Msg_N 9876 ("actual must exclude null to match generic formal#", Actual); 9877 end if; 9878 9879 -- A volatile object cannot be used as an actual in a generic instance. 9880 -- The following check is only relevant when SPARK_Mode is on as it is 9881 -- not a standard Ada legality rule. 9882 9883 if SPARK_Mode = On 9884 and then Present (Actual) 9885 and then Is_SPARK_Volatile_Object (Actual) 9886 then 9887 Error_Msg_N 9888 ("volatile object cannot act as actual in generic instantiation " 9889 & "(SPARK RM 7.1.3(8))", Actual); 9890 end if; 9891 9892 return List; 9893 end Instantiate_Object; 9894 9895 ------------------------------ 9896 -- Instantiate_Package_Body -- 9897 ------------------------------ 9898 9899 procedure Instantiate_Package_Body 9900 (Body_Info : Pending_Body_Info; 9901 Inlined_Body : Boolean := False; 9902 Body_Optional : Boolean := False) 9903 is 9904 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 9905 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 9906 Loc : constant Source_Ptr := Sloc (Inst_Node); 9907 9908 Gen_Id : constant Node_Id := Name (Inst_Node); 9909 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 9910 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 9911 Act_Spec : constant Node_Id := Specification (Act_Decl); 9912 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec); 9913 9914 Act_Body_Name : Node_Id; 9915 Gen_Body : Node_Id; 9916 Gen_Body_Id : Node_Id; 9917 Act_Body : Node_Id; 9918 Act_Body_Id : Entity_Id; 9919 9920 Parent_Installed : Boolean := False; 9921 Save_Style_Check : constant Boolean := Style_Check; 9922 9923 Par_Ent : Entity_Id := Empty; 9924 Par_Vis : Boolean := False; 9925 9926 Vis_Prims_List : Elist_Id := No_Elist; 9927 -- List of primitives made temporarily visible in the instantiation 9928 -- to match the visibility of the formal type 9929 9930 begin 9931 Gen_Body_Id := Corresponding_Body (Gen_Decl); 9932 9933 -- The instance body may already have been processed, as the parent of 9934 -- another instance that is inlined (Load_Parent_Of_Generic). 9935 9936 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 9937 return; 9938 end if; 9939 9940 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 9941 9942 -- Re-establish the state of information on which checks are suppressed. 9943 -- This information was set in Body_Info at the point of instantiation, 9944 -- and now we restore it so that the instance is compiled using the 9945 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). 9946 9947 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 9948 Scope_Suppress := Body_Info.Scope_Suppress; 9949 Opt.Ada_Version := Body_Info.Version; 9950 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 9951 Restore_Warnings (Body_Info.Warnings); 9952 Opt.SPARK_Mode := Body_Info.SPARK_Mode; 9953 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma; 9954 9955 if No (Gen_Body_Id) then 9956 Load_Parent_Of_Generic 9957 (Inst_Node, Specification (Gen_Decl), Body_Optional); 9958 Gen_Body_Id := Corresponding_Body (Gen_Decl); 9959 end if; 9960 9961 -- Establish global variable for sloc adjustment and for error recovery 9962 9963 Instantiation_Node := Inst_Node; 9964 9965 if Present (Gen_Body_Id) then 9966 Save_Env (Gen_Unit, Act_Decl_Id); 9967 Style_Check := False; 9968 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 9969 9970 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 9971 9972 Create_Instantiation_Source 9973 (Inst_Node, Gen_Body_Id, False, S_Adjustment); 9974 9975 Act_Body := 9976 Copy_Generic_Node 9977 (Original_Node (Gen_Body), Empty, Instantiating => True); 9978 9979 -- Build new name (possibly qualified) for body declaration 9980 9981 Act_Body_Id := New_Copy (Act_Decl_Id); 9982 9983 -- Some attributes of spec entity are not inherited by body entity 9984 9985 Set_Handler_Records (Act_Body_Id, No_List); 9986 9987 if Nkind (Defining_Unit_Name (Act_Spec)) = 9988 N_Defining_Program_Unit_Name 9989 then 9990 Act_Body_Name := 9991 Make_Defining_Program_Unit_Name (Loc, 9992 Name => New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 9993 Defining_Identifier => Act_Body_Id); 9994 else 9995 Act_Body_Name := Act_Body_Id; 9996 end if; 9997 9998 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 9999 10000 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 10001 Check_Generic_Actuals (Act_Decl_Id, False); 10002 10003 -- Install primitives hidden at the point of the instantiation but 10004 -- visible when processing the generic formals 10005 10006 declare 10007 E : Entity_Id; 10008 10009 begin 10010 E := First_Entity (Act_Decl_Id); 10011 while Present (E) loop 10012 if Is_Type (E) 10013 and then Is_Generic_Actual_Type (E) 10014 and then Is_Tagged_Type (E) 10015 then 10016 Install_Hidden_Primitives 10017 (Prims_List => Vis_Prims_List, 10018 Gen_T => Generic_Parent_Type (Parent (E)), 10019 Act_T => E); 10020 end if; 10021 10022 Next_Entity (E); 10023 end loop; 10024 end; 10025 10026 -- If it is a child unit, make the parent instance (which is an 10027 -- instance of the parent of the generic) visible. The parent 10028 -- instance is the prefix of the name of the generic unit. 10029 10030 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 10031 and then Nkind (Gen_Id) = N_Expanded_Name 10032 then 10033 Par_Ent := Entity (Prefix (Gen_Id)); 10034 Par_Vis := Is_Immediately_Visible (Par_Ent); 10035 Install_Parent (Par_Ent, In_Body => True); 10036 Parent_Installed := True; 10037 10038 elsif Is_Child_Unit (Gen_Unit) then 10039 Par_Ent := Scope (Gen_Unit); 10040 Par_Vis := Is_Immediately_Visible (Par_Ent); 10041 Install_Parent (Par_Ent, In_Body => True); 10042 Parent_Installed := True; 10043 end if; 10044 10045 -- If the instantiation is a library unit, and this is the main unit, 10046 -- then build the resulting compilation unit nodes for the instance. 10047 -- If this is a compilation unit but it is not the main unit, then it 10048 -- is the body of a unit in the context, that is being compiled 10049 -- because it is encloses some inlined unit or another generic unit 10050 -- being instantiated. In that case, this body is not part of the 10051 -- current compilation, and is not attached to the tree, but its 10052 -- parent must be set for analysis. 10053 10054 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10055 10056 -- Replace instance node with body of instance, and create new 10057 -- node for corresponding instance declaration. 10058 10059 Build_Instance_Compilation_Unit_Nodes 10060 (Inst_Node, Act_Body, Act_Decl); 10061 Analyze (Inst_Node); 10062 10063 if Parent (Inst_Node) = Cunit (Main_Unit) then 10064 10065 -- If the instance is a child unit itself, then set the scope 10066 -- of the expanded body to be the parent of the instantiation 10067 -- (ensuring that the fully qualified name will be generated 10068 -- for the elaboration subprogram). 10069 10070 if Nkind (Defining_Unit_Name (Act_Spec)) = 10071 N_Defining_Program_Unit_Name 10072 then 10073 Set_Scope 10074 (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 10075 end if; 10076 end if; 10077 10078 -- Case where instantiation is not a library unit 10079 10080 else 10081 -- If this is an early instantiation, i.e. appears textually 10082 -- before the corresponding body and must be elaborated first, 10083 -- indicate that the body instance is to be delayed. 10084 10085 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 10086 10087 -- Now analyze the body. We turn off all checks if this is an 10088 -- internal unit, since there is no reason to have checks on for 10089 -- any predefined run-time library code. All such code is designed 10090 -- to be compiled with checks off. 10091 10092 -- Note that we do NOT apply this criterion to children of GNAT 10093 -- (or on VMS, children of DEC). The latter units must suppress 10094 -- checks explicitly if this is needed. 10095 10096 if Is_Predefined_File_Name 10097 (Unit_File_Name (Get_Source_Unit (Gen_Decl))) 10098 then 10099 Analyze (Act_Body, Suppress => All_Checks); 10100 else 10101 Analyze (Act_Body); 10102 end if; 10103 end if; 10104 10105 Inherit_Context (Gen_Body, Inst_Node); 10106 10107 -- Remove the parent instances if they have been placed on the scope 10108 -- stack to compile the body. 10109 10110 if Parent_Installed then 10111 Remove_Parent (In_Body => True); 10112 10113 -- Restore the previous visibility of the parent 10114 10115 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 10116 end if; 10117 10118 Restore_Hidden_Primitives (Vis_Prims_List); 10119 Restore_Private_Views (Act_Decl_Id); 10120 10121 -- Remove the current unit from visibility if this is an instance 10122 -- that is not elaborated on the fly for inlining purposes. 10123 10124 if not Inlined_Body then 10125 Set_Is_Immediately_Visible (Act_Decl_Id, False); 10126 end if; 10127 10128 Restore_Env; 10129 Style_Check := Save_Style_Check; 10130 10131 -- If we have no body, and the unit requires a body, then complain. This 10132 -- complaint is suppressed if we have detected other errors (since a 10133 -- common reason for missing the body is that it had errors). 10134 -- In CodePeer mode, a warning has been emitted already, no need for 10135 -- further messages. 10136 10137 elsif Unit_Requires_Body (Gen_Unit) 10138 and then not Body_Optional 10139 then 10140 if CodePeer_Mode then 10141 null; 10142 10143 elsif Serious_Errors_Detected = 0 then 10144 Error_Msg_NE 10145 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 10146 10147 -- Don't attempt to perform any cleanup actions if some other error 10148 -- was already detected, since this can cause blowups. 10149 10150 else 10151 return; 10152 end if; 10153 10154 -- Case of package that does not need a body 10155 10156 else 10157 -- If the instantiation of the declaration is a library unit, rewrite 10158 -- the original package instantiation as a package declaration in the 10159 -- compilation unit node. 10160 10161 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10162 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 10163 Rewrite (Inst_Node, Act_Decl); 10164 10165 -- Generate elaboration entity, in case spec has elaboration code. 10166 -- This cannot be done when the instance is analyzed, because it 10167 -- is not known yet whether the body exists. 10168 10169 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 10170 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 10171 10172 -- If the instantiation is not a library unit, then append the 10173 -- declaration to the list of implicitly generated entities, unless 10174 -- it is already a list member which means that it was already 10175 -- processed 10176 10177 elsif not Is_List_Member (Act_Decl) then 10178 Mark_Rewrite_Insertion (Act_Decl); 10179 Insert_Before (Inst_Node, Act_Decl); 10180 end if; 10181 end if; 10182 10183 Expander_Mode_Restore; 10184 end Instantiate_Package_Body; 10185 10186 --------------------------------- 10187 -- Instantiate_Subprogram_Body -- 10188 --------------------------------- 10189 10190 procedure Instantiate_Subprogram_Body 10191 (Body_Info : Pending_Body_Info; 10192 Body_Optional : Boolean := False) 10193 is 10194 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 10195 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 10196 Loc : constant Source_Ptr := Sloc (Inst_Node); 10197 Gen_Id : constant Node_Id := Name (Inst_Node); 10198 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 10199 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 10200 Anon_Id : constant Entity_Id := 10201 Defining_Unit_Name (Specification (Act_Decl)); 10202 Pack_Id : constant Entity_Id := 10203 Defining_Unit_Name (Parent (Act_Decl)); 10204 Decls : List_Id; 10205 Gen_Body : Node_Id; 10206 Gen_Body_Id : Node_Id; 10207 Act_Body : Node_Id; 10208 Pack_Body : Node_Id; 10209 Prev_Formal : Entity_Id; 10210 Ret_Expr : Node_Id; 10211 Unit_Renaming : Node_Id; 10212 10213 Parent_Installed : Boolean := False; 10214 10215 Saved_Style_Check : constant Boolean := Style_Check; 10216 Saved_Warnings : constant Warning_Record := Save_Warnings; 10217 10218 Par_Ent : Entity_Id := Empty; 10219 Par_Vis : Boolean := False; 10220 10221 begin 10222 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10223 10224 -- Subprogram body may have been created already because of an inline 10225 -- pragma, or because of multiple elaborations of the enclosing package 10226 -- when several instances of the subprogram appear in the main unit. 10227 10228 if Present (Corresponding_Body (Act_Decl)) then 10229 return; 10230 end if; 10231 10232 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 10233 10234 -- Re-establish the state of information on which checks are suppressed. 10235 -- This information was set in Body_Info at the point of instantiation, 10236 -- and now we restore it so that the instance is compiled using the 10237 -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). 10238 10239 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 10240 Scope_Suppress := Body_Info.Scope_Suppress; 10241 Opt.Ada_Version := Body_Info.Version; 10242 Opt.Ada_Version_Pragma := Body_Info.Version_Pragma; 10243 Restore_Warnings (Body_Info.Warnings); 10244 Opt.SPARK_Mode := Body_Info.SPARK_Mode; 10245 Opt.SPARK_Mode_Pragma := Body_Info.SPARK_Mode_Pragma; 10246 10247 if No (Gen_Body_Id) then 10248 10249 -- For imported generic subprogram, no body to compile, complete 10250 -- the spec entity appropriately. 10251 10252 if Is_Imported (Gen_Unit) then 10253 Set_Is_Imported (Anon_Id); 10254 Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit)); 10255 Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit)); 10256 Set_Convention (Anon_Id, Convention (Gen_Unit)); 10257 Set_Has_Completion (Anon_Id); 10258 return; 10259 10260 -- For other cases, compile the body 10261 10262 else 10263 Load_Parent_Of_Generic 10264 (Inst_Node, Specification (Gen_Decl), Body_Optional); 10265 Gen_Body_Id := Corresponding_Body (Gen_Decl); 10266 end if; 10267 end if; 10268 10269 Instantiation_Node := Inst_Node; 10270 10271 if Present (Gen_Body_Id) then 10272 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 10273 10274 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 10275 10276 -- Either body is not present, or context is non-expanding, as 10277 -- when compiling a subunit. Mark the instance as completed, and 10278 -- diagnose a missing body when needed. 10279 10280 if Expander_Active 10281 and then Operating_Mode = Generate_Code 10282 then 10283 Error_Msg_N 10284 ("missing proper body for instantiation", Gen_Body); 10285 end if; 10286 10287 Set_Has_Completion (Anon_Id); 10288 return; 10289 end if; 10290 10291 Save_Env (Gen_Unit, Anon_Id); 10292 Style_Check := False; 10293 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 10294 Create_Instantiation_Source 10295 (Inst_Node, 10296 Gen_Body_Id, 10297 False, 10298 S_Adjustment); 10299 10300 Act_Body := 10301 Copy_Generic_Node 10302 (Original_Node (Gen_Body), Empty, Instantiating => True); 10303 10304 -- Create proper defining name for the body, to correspond to 10305 -- the one in the spec. 10306 10307 Set_Defining_Unit_Name (Specification (Act_Body), 10308 Make_Defining_Identifier 10309 (Sloc (Defining_Entity (Inst_Node)), Chars (Anon_Id))); 10310 Set_Corresponding_Spec (Act_Body, Anon_Id); 10311 Set_Has_Completion (Anon_Id); 10312 Check_Generic_Actuals (Pack_Id, False); 10313 10314 -- Generate a reference to link the visible subprogram instance to 10315 -- the generic body, which for navigation purposes is the only 10316 -- available source for the instance. 10317 10318 Generate_Reference 10319 (Related_Instance (Pack_Id), 10320 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 10321 10322 -- If it is a child unit, make the parent instance (which is an 10323 -- instance of the parent of the generic) visible. The parent 10324 -- instance is the prefix of the name of the generic unit. 10325 10326 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 10327 and then Nkind (Gen_Id) = N_Expanded_Name 10328 then 10329 Par_Ent := Entity (Prefix (Gen_Id)); 10330 Par_Vis := Is_Immediately_Visible (Par_Ent); 10331 Install_Parent (Par_Ent, In_Body => True); 10332 Parent_Installed := True; 10333 10334 elsif Is_Child_Unit (Gen_Unit) then 10335 Par_Ent := Scope (Gen_Unit); 10336 Par_Vis := Is_Immediately_Visible (Par_Ent); 10337 Install_Parent (Par_Ent, In_Body => True); 10338 Parent_Installed := True; 10339 end if; 10340 10341 -- Inside its body, a reference to the generic unit is a reference 10342 -- to the instance. The corresponding renaming is the first 10343 -- declaration in the body. 10344 10345 Unit_Renaming := 10346 Make_Subprogram_Renaming_Declaration (Loc, 10347 Specification => 10348 Copy_Generic_Node ( 10349 Specification (Original_Node (Gen_Body)), 10350 Empty, 10351 Instantiating => True), 10352 Name => New_Occurrence_Of (Anon_Id, Loc)); 10353 10354 -- If there is a formal subprogram with the same name as the unit 10355 -- itself, do not add this renaming declaration. This is a temporary 10356 -- fix for one ACVC test. ??? 10357 10358 Prev_Formal := First_Entity (Pack_Id); 10359 while Present (Prev_Formal) loop 10360 if Chars (Prev_Formal) = Chars (Gen_Unit) 10361 and then Is_Overloadable (Prev_Formal) 10362 then 10363 exit; 10364 end if; 10365 10366 Next_Entity (Prev_Formal); 10367 end loop; 10368 10369 if Present (Prev_Formal) then 10370 Decls := New_List (Act_Body); 10371 else 10372 Decls := New_List (Unit_Renaming, Act_Body); 10373 end if; 10374 10375 -- The subprogram body is placed in the body of a dummy package body, 10376 -- whose spec contains the subprogram declaration as well as the 10377 -- renaming declarations for the generic parameters. 10378 10379 Pack_Body := Make_Package_Body (Loc, 10380 Defining_Unit_Name => New_Copy (Pack_Id), 10381 Declarations => Decls); 10382 10383 Set_Corresponding_Spec (Pack_Body, Pack_Id); 10384 10385 -- If the instantiation is a library unit, then build resulting 10386 -- compilation unit nodes for the instance. The declaration of 10387 -- the enclosing package is the grandparent of the subprogram 10388 -- declaration. First replace the instantiation node as the unit 10389 -- of the corresponding compilation. 10390 10391 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 10392 if Parent (Inst_Node) = Cunit (Main_Unit) then 10393 Set_Unit (Parent (Inst_Node), Inst_Node); 10394 Build_Instance_Compilation_Unit_Nodes 10395 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 10396 Analyze (Inst_Node); 10397 else 10398 Set_Parent (Pack_Body, Parent (Inst_Node)); 10399 Analyze (Pack_Body); 10400 end if; 10401 10402 else 10403 Insert_Before (Inst_Node, Pack_Body); 10404 Mark_Rewrite_Insertion (Pack_Body); 10405 Analyze (Pack_Body); 10406 10407 if Expander_Active then 10408 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 10409 end if; 10410 end if; 10411 10412 Inherit_Context (Gen_Body, Inst_Node); 10413 10414 Restore_Private_Views (Pack_Id, False); 10415 10416 if Parent_Installed then 10417 Remove_Parent (In_Body => True); 10418 10419 -- Restore the previous visibility of the parent 10420 10421 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 10422 end if; 10423 10424 Restore_Env; 10425 Style_Check := Saved_Style_Check; 10426 Restore_Warnings (Saved_Warnings); 10427 10428 -- Body not found. Error was emitted already. If there were no previous 10429 -- errors, this may be an instance whose scope is a premature instance. 10430 -- In that case we must insure that the (legal) program does raise 10431 -- program error if executed. We generate a subprogram body for this 10432 -- purpose. See DEC ac30vso. 10433 10434 -- Should not reference proprietary DEC tests in comments ??? 10435 10436 elsif Serious_Errors_Detected = 0 10437 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 10438 then 10439 if Body_Optional then 10440 return; 10441 10442 elsif Ekind (Anon_Id) = E_Procedure then 10443 Act_Body := 10444 Make_Subprogram_Body (Loc, 10445 Specification => 10446 Make_Procedure_Specification (Loc, 10447 Defining_Unit_Name => 10448 Make_Defining_Identifier (Loc, Chars (Anon_Id)), 10449 Parameter_Specifications => 10450 New_Copy_List 10451 (Parameter_Specifications (Parent (Anon_Id)))), 10452 10453 Declarations => Empty_List, 10454 Handled_Statement_Sequence => 10455 Make_Handled_Sequence_Of_Statements (Loc, 10456 Statements => 10457 New_List ( 10458 Make_Raise_Program_Error (Loc, 10459 Reason => 10460 PE_Access_Before_Elaboration)))); 10461 10462 else 10463 Ret_Expr := 10464 Make_Raise_Program_Error (Loc, 10465 Reason => PE_Access_Before_Elaboration); 10466 10467 Set_Etype (Ret_Expr, (Etype (Anon_Id))); 10468 Set_Analyzed (Ret_Expr); 10469 10470 Act_Body := 10471 Make_Subprogram_Body (Loc, 10472 Specification => 10473 Make_Function_Specification (Loc, 10474 Defining_Unit_Name => 10475 Make_Defining_Identifier (Loc, Chars (Anon_Id)), 10476 Parameter_Specifications => 10477 New_Copy_List 10478 (Parameter_Specifications (Parent (Anon_Id))), 10479 Result_Definition => 10480 New_Occurrence_Of (Etype (Anon_Id), Loc)), 10481 10482 Declarations => Empty_List, 10483 Handled_Statement_Sequence => 10484 Make_Handled_Sequence_Of_Statements (Loc, 10485 Statements => 10486 New_List 10487 (Make_Simple_Return_Statement (Loc, Ret_Expr)))); 10488 end if; 10489 10490 Pack_Body := Make_Package_Body (Loc, 10491 Defining_Unit_Name => New_Copy (Pack_Id), 10492 Declarations => New_List (Act_Body)); 10493 10494 Insert_After (Inst_Node, Pack_Body); 10495 Set_Corresponding_Spec (Pack_Body, Pack_Id); 10496 Analyze (Pack_Body); 10497 end if; 10498 10499 Expander_Mode_Restore; 10500 end Instantiate_Subprogram_Body; 10501 10502 ---------------------- 10503 -- Instantiate_Type -- 10504 ---------------------- 10505 10506 function Instantiate_Type 10507 (Formal : Node_Id; 10508 Actual : Node_Id; 10509 Analyzed_Formal : Node_Id; 10510 Actual_Decls : List_Id) return List_Id 10511 is 10512 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 10513 A_Gen_T : constant Entity_Id := 10514 Defining_Identifier (Analyzed_Formal); 10515 Ancestor : Entity_Id := Empty; 10516 Def : constant Node_Id := Formal_Type_Definition (Formal); 10517 Act_T : Entity_Id; 10518 Decl_Node : Node_Id; 10519 Decl_Nodes : List_Id; 10520 Loc : Source_Ptr; 10521 Subt : Entity_Id; 10522 10523 procedure Validate_Array_Type_Instance; 10524 procedure Validate_Access_Subprogram_Instance; 10525 procedure Validate_Access_Type_Instance; 10526 procedure Validate_Derived_Type_Instance; 10527 procedure Validate_Derived_Interface_Type_Instance; 10528 procedure Validate_Discriminated_Formal_Type; 10529 procedure Validate_Interface_Type_Instance; 10530 procedure Validate_Private_Type_Instance; 10531 procedure Validate_Incomplete_Type_Instance; 10532 -- These procedures perform validation tests for the named case. 10533 -- Validate_Discriminated_Formal_Type is shared by formal private 10534 -- types and Ada 2012 formal incomplete types. 10535 10536 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 10537 -- Check that base types are the same and that the subtypes match 10538 -- statically. Used in several of the above. 10539 10540 -------------------- 10541 -- Subtypes_Match -- 10542 -------------------- 10543 10544 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 10545 T : constant Entity_Id := Get_Instance_Of (Gen_T); 10546 10547 begin 10548 -- Some detailed comments would be useful here ??? 10549 10550 return ((Base_Type (T) = Act_T 10551 or else Base_Type (T) = Base_Type (Act_T)) 10552 and then Subtypes_Statically_Match (T, Act_T)) 10553 10554 or else (Is_Class_Wide_Type (Gen_T) 10555 and then Is_Class_Wide_Type (Act_T) 10556 and then Subtypes_Match 10557 (Get_Instance_Of (Root_Type (Gen_T)), 10558 Root_Type (Act_T))) 10559 10560 or else 10561 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 10562 E_Anonymous_Access_Type) 10563 and then Ekind (Act_T) = Ekind (Gen_T) 10564 and then Subtypes_Statically_Match 10565 (Designated_Type (Gen_T), Designated_Type (Act_T))); 10566 end Subtypes_Match; 10567 10568 ----------------------------------------- 10569 -- Validate_Access_Subprogram_Instance -- 10570 ----------------------------------------- 10571 10572 procedure Validate_Access_Subprogram_Instance is 10573 begin 10574 if not Is_Access_Type (Act_T) 10575 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 10576 then 10577 Error_Msg_NE 10578 ("expect access type in instantiation of &", Actual, Gen_T); 10579 Abandon_Instantiation (Actual); 10580 end if; 10581 10582 -- According to AI05-288, actuals for access_to_subprograms must be 10583 -- subtype conformant with the generic formal. Previous to AI05-288 10584 -- only mode conformance was required. 10585 10586 -- This is a binding interpretation that applies to previous versions 10587 -- of the language, no need to maintain previous weaker checks. 10588 10589 Check_Subtype_Conformant 10590 (Designated_Type (Act_T), 10591 Designated_Type (A_Gen_T), 10592 Actual, 10593 Get_Inst => True); 10594 10595 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 10596 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 10597 Error_Msg_NE 10598 ("protected access type not allowed for formal &", 10599 Actual, Gen_T); 10600 end if; 10601 10602 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 10603 Error_Msg_NE 10604 ("expect protected access type for formal &", 10605 Actual, Gen_T); 10606 end if; 10607 end Validate_Access_Subprogram_Instance; 10608 10609 ----------------------------------- 10610 -- Validate_Access_Type_Instance -- 10611 ----------------------------------- 10612 10613 procedure Validate_Access_Type_Instance is 10614 Desig_Type : constant Entity_Id := 10615 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 10616 Desig_Act : Entity_Id; 10617 10618 begin 10619 if not Is_Access_Type (Act_T) then 10620 Error_Msg_NE 10621 ("expect access type in instantiation of &", Actual, Gen_T); 10622 Abandon_Instantiation (Actual); 10623 end if; 10624 10625 if Is_Access_Constant (A_Gen_T) then 10626 if not Is_Access_Constant (Act_T) then 10627 Error_Msg_N 10628 ("actual type must be access-to-constant type", Actual); 10629 Abandon_Instantiation (Actual); 10630 end if; 10631 else 10632 if Is_Access_Constant (Act_T) then 10633 Error_Msg_N 10634 ("actual type must be access-to-variable type", Actual); 10635 Abandon_Instantiation (Actual); 10636 10637 elsif Ekind (A_Gen_T) = E_General_Access_Type 10638 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 10639 then 10640 Error_Msg_N -- CODEFIX 10641 ("actual must be general access type!", Actual); 10642 Error_Msg_NE -- CODEFIX 10643 ("add ALL to }!", Actual, Act_T); 10644 Abandon_Instantiation (Actual); 10645 end if; 10646 end if; 10647 10648 -- The designated subtypes, that is to say the subtypes introduced 10649 -- by an access type declaration (and not by a subtype declaration) 10650 -- must match. 10651 10652 Desig_Act := Designated_Type (Base_Type (Act_T)); 10653 10654 -- The designated type may have been introduced through a limited_ 10655 -- with clause, in which case retrieve the non-limited view. This 10656 -- applies to incomplete types as well as to class-wide types. 10657 10658 if From_Limited_With (Desig_Act) then 10659 Desig_Act := Available_View (Desig_Act); 10660 end if; 10661 10662 if not Subtypes_Match (Desig_Type, Desig_Act) then 10663 Error_Msg_NE 10664 ("designated type of actual does not match that of formal &", 10665 Actual, Gen_T); 10666 10667 if not Predicates_Match (Desig_Type, Desig_Act) then 10668 Error_Msg_N ("\predicates do not match", Actual); 10669 end if; 10670 10671 Abandon_Instantiation (Actual); 10672 10673 elsif Is_Access_Type (Designated_Type (Act_T)) 10674 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 10675 /= 10676 Is_Constrained (Designated_Type (Desig_Type)) 10677 then 10678 Error_Msg_NE 10679 ("designated type of actual does not match that of formal &", 10680 Actual, Gen_T); 10681 10682 if not Predicates_Match (Desig_Type, Desig_Act) then 10683 Error_Msg_N ("\predicates do not match", Actual); 10684 end if; 10685 10686 Abandon_Instantiation (Actual); 10687 end if; 10688 10689 -- Ada 2005: null-exclusion indicators of the two types must agree 10690 10691 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 10692 Error_Msg_NE 10693 ("non null exclusion of actual and formal & do not match", 10694 Actual, Gen_T); 10695 end if; 10696 end Validate_Access_Type_Instance; 10697 10698 ---------------------------------- 10699 -- Validate_Array_Type_Instance -- 10700 ---------------------------------- 10701 10702 procedure Validate_Array_Type_Instance is 10703 I1 : Node_Id; 10704 I2 : Node_Id; 10705 T2 : Entity_Id; 10706 10707 function Formal_Dimensions return Int; 10708 -- Count number of dimensions in array type formal 10709 10710 ----------------------- 10711 -- Formal_Dimensions -- 10712 ----------------------- 10713 10714 function Formal_Dimensions return Int is 10715 Num : Int := 0; 10716 Index : Node_Id; 10717 10718 begin 10719 if Nkind (Def) = N_Constrained_Array_Definition then 10720 Index := First (Discrete_Subtype_Definitions (Def)); 10721 else 10722 Index := First (Subtype_Marks (Def)); 10723 end if; 10724 10725 while Present (Index) loop 10726 Num := Num + 1; 10727 Next_Index (Index); 10728 end loop; 10729 10730 return Num; 10731 end Formal_Dimensions; 10732 10733 -- Start of processing for Validate_Array_Type_Instance 10734 10735 begin 10736 if not Is_Array_Type (Act_T) then 10737 Error_Msg_NE 10738 ("expect array type in instantiation of &", Actual, Gen_T); 10739 Abandon_Instantiation (Actual); 10740 10741 elsif Nkind (Def) = N_Constrained_Array_Definition then 10742 if not (Is_Constrained (Act_T)) then 10743 Error_Msg_NE 10744 ("expect constrained array in instantiation of &", 10745 Actual, Gen_T); 10746 Abandon_Instantiation (Actual); 10747 end if; 10748 10749 else 10750 if Is_Constrained (Act_T) then 10751 Error_Msg_NE 10752 ("expect unconstrained array in instantiation of &", 10753 Actual, Gen_T); 10754 Abandon_Instantiation (Actual); 10755 end if; 10756 end if; 10757 10758 if Formal_Dimensions /= Number_Dimensions (Act_T) then 10759 Error_Msg_NE 10760 ("dimensions of actual do not match formal &", Actual, Gen_T); 10761 Abandon_Instantiation (Actual); 10762 end if; 10763 10764 I1 := First_Index (A_Gen_T); 10765 I2 := First_Index (Act_T); 10766 for J in 1 .. Formal_Dimensions loop 10767 10768 -- If the indexes of the actual were given by a subtype_mark, 10769 -- the index was transformed into a range attribute. Retrieve 10770 -- the original type mark for checking. 10771 10772 if Is_Entity_Name (Original_Node (I2)) then 10773 T2 := Entity (Original_Node (I2)); 10774 else 10775 T2 := Etype (I2); 10776 end if; 10777 10778 if not Subtypes_Match 10779 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 10780 then 10781 Error_Msg_NE 10782 ("index types of actual do not match those of formal &", 10783 Actual, Gen_T); 10784 Abandon_Instantiation (Actual); 10785 end if; 10786 10787 Next_Index (I1); 10788 Next_Index (I2); 10789 end loop; 10790 10791 -- Check matching subtypes. Note that there are complex visibility 10792 -- issues when the generic is a child unit and some aspect of the 10793 -- generic type is declared in a parent unit of the generic. We do 10794 -- the test to handle this special case only after a direct check 10795 -- for static matching has failed. The case where both the component 10796 -- type and the array type are separate formals, and the component 10797 -- type is a private view may also require special checking in 10798 -- Subtypes_Match. 10799 10800 if Subtypes_Match 10801 (Component_Type (A_Gen_T), Component_Type (Act_T)) 10802 or else Subtypes_Match 10803 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 10804 Component_Type (Act_T)) 10805 then 10806 null; 10807 else 10808 Error_Msg_NE 10809 ("component subtype of actual does not match that of formal &", 10810 Actual, Gen_T); 10811 Abandon_Instantiation (Actual); 10812 end if; 10813 10814 if Has_Aliased_Components (A_Gen_T) 10815 and then not Has_Aliased_Components (Act_T) 10816 then 10817 Error_Msg_NE 10818 ("actual must have aliased components to match formal type &", 10819 Actual, Gen_T); 10820 end if; 10821 end Validate_Array_Type_Instance; 10822 10823 ----------------------------------------------- 10824 -- Validate_Derived_Interface_Type_Instance -- 10825 ----------------------------------------------- 10826 10827 procedure Validate_Derived_Interface_Type_Instance is 10828 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 10829 Elmt : Elmt_Id; 10830 10831 begin 10832 -- First apply interface instance checks 10833 10834 Validate_Interface_Type_Instance; 10835 10836 -- Verify that immediate parent interface is an ancestor of 10837 -- the actual. 10838 10839 if Present (Par) 10840 and then not Interface_Present_In_Ancestor (Act_T, Par) 10841 then 10842 Error_Msg_NE 10843 ("interface actual must include progenitor&", Actual, Par); 10844 end if; 10845 10846 -- Now verify that the actual includes all other ancestors of 10847 -- the formal. 10848 10849 Elmt := First_Elmt (Interfaces (A_Gen_T)); 10850 while Present (Elmt) loop 10851 if not Interface_Present_In_Ancestor 10852 (Act_T, Get_Instance_Of (Node (Elmt))) 10853 then 10854 Error_Msg_NE 10855 ("interface actual must include progenitor&", 10856 Actual, Node (Elmt)); 10857 end if; 10858 10859 Next_Elmt (Elmt); 10860 end loop; 10861 end Validate_Derived_Interface_Type_Instance; 10862 10863 ------------------------------------ 10864 -- Validate_Derived_Type_Instance -- 10865 ------------------------------------ 10866 10867 procedure Validate_Derived_Type_Instance is 10868 Actual_Discr : Entity_Id; 10869 Ancestor_Discr : Entity_Id; 10870 10871 begin 10872 -- If the parent type in the generic declaration is itself a previous 10873 -- formal type, then it is local to the generic and absent from the 10874 -- analyzed generic definition. In that case the ancestor is the 10875 -- instance of the formal (which must have been instantiated 10876 -- previously), unless the ancestor is itself a formal derived type. 10877 -- In this latter case (which is the subject of Corrigendum 8652/0038 10878 -- (AI-202) the ancestor of the formals is the ancestor of its 10879 -- parent. Otherwise, the analyzed generic carries the parent type. 10880 -- If the parent type is defined in a previous formal package, then 10881 -- the scope of that formal package is that of the generic type 10882 -- itself, and it has already been mapped into the corresponding type 10883 -- in the actual package. 10884 10885 -- Common case: parent type defined outside of the generic 10886 10887 if Is_Entity_Name (Subtype_Mark (Def)) 10888 and then Present (Entity (Subtype_Mark (Def))) 10889 then 10890 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 10891 10892 -- Check whether parent is defined in a previous formal package 10893 10894 elsif 10895 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 10896 then 10897 Ancestor := 10898 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 10899 10900 -- The type may be a local derivation, or a type extension of a 10901 -- previous formal, or of a formal of a parent package. 10902 10903 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 10904 or else 10905 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 10906 then 10907 -- Check whether the parent is another derived formal type in the 10908 -- same generic unit. 10909 10910 if Etype (A_Gen_T) /= A_Gen_T 10911 and then Is_Generic_Type (Etype (A_Gen_T)) 10912 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 10913 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 10914 then 10915 -- Locate ancestor of parent from the subtype declaration 10916 -- created for the actual. 10917 10918 declare 10919 Decl : Node_Id; 10920 10921 begin 10922 Decl := First (Actual_Decls); 10923 while Present (Decl) loop 10924 if Nkind (Decl) = N_Subtype_Declaration 10925 and then Chars (Defining_Identifier (Decl)) = 10926 Chars (Etype (A_Gen_T)) 10927 then 10928 Ancestor := Generic_Parent_Type (Decl); 10929 exit; 10930 else 10931 Next (Decl); 10932 end if; 10933 end loop; 10934 end; 10935 10936 pragma Assert (Present (Ancestor)); 10937 10938 -- The ancestor itself may be a previous formal that has been 10939 -- instantiated. 10940 10941 Ancestor := Get_Instance_Of (Ancestor); 10942 10943 else 10944 Ancestor := 10945 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 10946 end if; 10947 10948 -- An unusual case: the actual is a type declared in a parent unit, 10949 -- but is not a formal type so there is no instance_of for it. 10950 -- Retrieve it by analyzing the record extension. 10951 10952 elsif Is_Child_Unit (Scope (A_Gen_T)) 10953 and then In_Open_Scopes (Scope (Act_T)) 10954 and then Is_Generic_Instance (Scope (Act_T)) 10955 then 10956 Analyze (Subtype_Mark (Def)); 10957 Ancestor := Entity (Subtype_Mark (Def)); 10958 10959 else 10960 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 10961 end if; 10962 10963 -- If the formal derived type has pragma Preelaborable_Initialization 10964 -- then the actual type must have preelaborable initialization. 10965 10966 if Known_To_Have_Preelab_Init (A_Gen_T) 10967 and then not Has_Preelaborable_Initialization (Act_T) 10968 then 10969 Error_Msg_NE 10970 ("actual for & must have preelaborable initialization", 10971 Actual, Gen_T); 10972 end if; 10973 10974 -- Ada 2005 (AI-251) 10975 10976 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then 10977 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 10978 Error_Msg_NE 10979 ("(Ada 2005) expected type implementing & in instantiation", 10980 Actual, Ancestor); 10981 end if; 10982 10983 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 10984 Error_Msg_NE 10985 ("expect type derived from & in instantiation", 10986 Actual, First_Subtype (Ancestor)); 10987 Abandon_Instantiation (Actual); 10988 end if; 10989 10990 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 10991 -- that the formal type declaration has been rewritten as a private 10992 -- extension. 10993 10994 if Ada_Version >= Ada_2005 10995 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 10996 and then Synchronized_Present (Parent (A_Gen_T)) 10997 then 10998 -- The actual must be a synchronized tagged type 10999 11000 if not Is_Tagged_Type (Act_T) then 11001 Error_Msg_N 11002 ("actual of synchronized type must be tagged", Actual); 11003 Abandon_Instantiation (Actual); 11004 11005 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 11006 and then Nkind (Type_Definition (Parent (Act_T))) = 11007 N_Derived_Type_Definition 11008 and then not Synchronized_Present (Type_Definition 11009 (Parent (Act_T))) 11010 then 11011 Error_Msg_N 11012 ("actual of synchronized type must be synchronized", Actual); 11013 Abandon_Instantiation (Actual); 11014 end if; 11015 end if; 11016 11017 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 11018 -- removes the second instance of the phrase "or allow pass by copy". 11019 11020 if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then 11021 Error_Msg_N 11022 ("cannot have atomic actual type for non-atomic formal type", 11023 Actual); 11024 11025 elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then 11026 Error_Msg_N 11027 ("cannot have volatile actual type for non-volatile formal type", 11028 Actual); 11029 end if; 11030 11031 -- It should not be necessary to check for unknown discriminants on 11032 -- Formal, but for some reason Has_Unknown_Discriminants is false for 11033 -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This 11034 -- needs fixing. ??? 11035 11036 if not Is_Indefinite_Subtype (A_Gen_T) 11037 and then not Unknown_Discriminants_Present (Formal) 11038 and then Is_Indefinite_Subtype (Act_T) 11039 then 11040 Error_Msg_N 11041 ("actual subtype must be constrained", Actual); 11042 Abandon_Instantiation (Actual); 11043 end if; 11044 11045 if not Unknown_Discriminants_Present (Formal) then 11046 if Is_Constrained (Ancestor) then 11047 if not Is_Constrained (Act_T) then 11048 Error_Msg_N 11049 ("actual subtype must be constrained", Actual); 11050 Abandon_Instantiation (Actual); 11051 end if; 11052 11053 -- Ancestor is unconstrained, Check if generic formal and actual 11054 -- agree on constrainedness. The check only applies to array types 11055 -- and discriminated types. 11056 11057 elsif Is_Constrained (Act_T) then 11058 if Ekind (Ancestor) = E_Access_Type 11059 or else 11060 (not Is_Constrained (A_Gen_T) 11061 and then Is_Composite_Type (A_Gen_T)) 11062 then 11063 Error_Msg_N 11064 ("actual subtype must be unconstrained", Actual); 11065 Abandon_Instantiation (Actual); 11066 end if; 11067 11068 -- A class-wide type is only allowed if the formal has unknown 11069 -- discriminants. 11070 11071 elsif Is_Class_Wide_Type (Act_T) 11072 and then not Has_Unknown_Discriminants (Ancestor) 11073 then 11074 Error_Msg_NE 11075 ("actual for & cannot be a class-wide type", Actual, Gen_T); 11076 Abandon_Instantiation (Actual); 11077 11078 -- Otherwise, the formal and actual shall have the same number 11079 -- of discriminants and each discriminant of the actual must 11080 -- correspond to a discriminant of the formal. 11081 11082 elsif Has_Discriminants (Act_T) 11083 and then not Has_Unknown_Discriminants (Act_T) 11084 and then Has_Discriminants (Ancestor) 11085 then 11086 Actual_Discr := First_Discriminant (Act_T); 11087 Ancestor_Discr := First_Discriminant (Ancestor); 11088 while Present (Actual_Discr) 11089 and then Present (Ancestor_Discr) 11090 loop 11091 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 11092 No (Corresponding_Discriminant (Actual_Discr)) 11093 then 11094 Error_Msg_NE 11095 ("discriminant & does not correspond " & 11096 "to ancestor discriminant", Actual, Actual_Discr); 11097 Abandon_Instantiation (Actual); 11098 end if; 11099 11100 Next_Discriminant (Actual_Discr); 11101 Next_Discriminant (Ancestor_Discr); 11102 end loop; 11103 11104 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 11105 Error_Msg_NE 11106 ("actual for & must have same number of discriminants", 11107 Actual, Gen_T); 11108 Abandon_Instantiation (Actual); 11109 end if; 11110 11111 -- This case should be caught by the earlier check for 11112 -- constrainedness, but the check here is added for completeness. 11113 11114 elsif Has_Discriminants (Act_T) 11115 and then not Has_Unknown_Discriminants (Act_T) 11116 then 11117 Error_Msg_NE 11118 ("actual for & must not have discriminants", Actual, Gen_T); 11119 Abandon_Instantiation (Actual); 11120 11121 elsif Has_Discriminants (Ancestor) then 11122 Error_Msg_NE 11123 ("actual for & must have known discriminants", Actual, Gen_T); 11124 Abandon_Instantiation (Actual); 11125 end if; 11126 11127 if not Subtypes_Statically_Compatible 11128 (Act_T, Ancestor, Formal_Derived_Matching => True) 11129 then 11130 Error_Msg_N 11131 ("constraint on actual is incompatible with formal", Actual); 11132 Abandon_Instantiation (Actual); 11133 end if; 11134 end if; 11135 11136 -- If the formal and actual types are abstract, check that there 11137 -- are no abstract primitives of the actual type that correspond to 11138 -- nonabstract primitives of the formal type (second sentence of 11139 -- RM95-3.9.3(9)). 11140 11141 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 11142 Check_Abstract_Primitives : declare 11143 Gen_Prims : constant Elist_Id := 11144 Primitive_Operations (A_Gen_T); 11145 Gen_Elmt : Elmt_Id; 11146 Gen_Subp : Entity_Id; 11147 Anc_Subp : Entity_Id; 11148 Anc_Formal : Entity_Id; 11149 Anc_F_Type : Entity_Id; 11150 11151 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 11152 Act_Elmt : Elmt_Id; 11153 Act_Subp : Entity_Id; 11154 Act_Formal : Entity_Id; 11155 Act_F_Type : Entity_Id; 11156 11157 Subprograms_Correspond : Boolean; 11158 11159 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 11160 -- Returns true if T2 is derived directly or indirectly from 11161 -- T1, including derivations from interfaces. T1 and T2 are 11162 -- required to be specific tagged base types. 11163 11164 ------------------------ 11165 -- Is_Tagged_Ancestor -- 11166 ------------------------ 11167 11168 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 11169 is 11170 Intfc_Elmt : Elmt_Id; 11171 11172 begin 11173 -- The predicate is satisfied if the types are the same 11174 11175 if T1 = T2 then 11176 return True; 11177 11178 -- If we've reached the top of the derivation chain then 11179 -- we know that T1 is not an ancestor of T2. 11180 11181 elsif Etype (T2) = T2 then 11182 return False; 11183 11184 -- Proceed to check T2's immediate parent 11185 11186 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 11187 return True; 11188 11189 -- Finally, check to see if T1 is an ancestor of any of T2's 11190 -- progenitors. 11191 11192 else 11193 Intfc_Elmt := First_Elmt (Interfaces (T2)); 11194 while Present (Intfc_Elmt) loop 11195 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 11196 return True; 11197 end if; 11198 11199 Next_Elmt (Intfc_Elmt); 11200 end loop; 11201 end if; 11202 11203 return False; 11204 end Is_Tagged_Ancestor; 11205 11206 -- Start of processing for Check_Abstract_Primitives 11207 11208 begin 11209 -- Loop over all of the formal derived type's primitives 11210 11211 Gen_Elmt := First_Elmt (Gen_Prims); 11212 while Present (Gen_Elmt) loop 11213 Gen_Subp := Node (Gen_Elmt); 11214 11215 -- If the primitive of the formal is not abstract, then 11216 -- determine whether there is a corresponding primitive of 11217 -- the actual type that's abstract. 11218 11219 if not Is_Abstract_Subprogram (Gen_Subp) then 11220 Act_Elmt := First_Elmt (Act_Prims); 11221 while Present (Act_Elmt) loop 11222 Act_Subp := Node (Act_Elmt); 11223 11224 -- If we find an abstract primitive of the actual, 11225 -- then we need to test whether it corresponds to the 11226 -- subprogram from which the generic formal primitive 11227 -- is inherited. 11228 11229 if Is_Abstract_Subprogram (Act_Subp) then 11230 Anc_Subp := Alias (Gen_Subp); 11231 11232 -- Test whether we have a corresponding primitive 11233 -- by comparing names, kinds, formal types, and 11234 -- result types. 11235 11236 if Chars (Anc_Subp) = Chars (Act_Subp) 11237 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 11238 then 11239 Anc_Formal := First_Formal (Anc_Subp); 11240 Act_Formal := First_Formal (Act_Subp); 11241 while Present (Anc_Formal) 11242 and then Present (Act_Formal) 11243 loop 11244 Anc_F_Type := Etype (Anc_Formal); 11245 Act_F_Type := Etype (Act_Formal); 11246 11247 if Ekind (Anc_F_Type) 11248 = E_Anonymous_Access_Type 11249 then 11250 Anc_F_Type := Designated_Type (Anc_F_Type); 11251 11252 if Ekind (Act_F_Type) 11253 = E_Anonymous_Access_Type 11254 then 11255 Act_F_Type := 11256 Designated_Type (Act_F_Type); 11257 else 11258 exit; 11259 end if; 11260 11261 elsif 11262 Ekind (Act_F_Type) = E_Anonymous_Access_Type 11263 then 11264 exit; 11265 end if; 11266 11267 Anc_F_Type := Base_Type (Anc_F_Type); 11268 Act_F_Type := Base_Type (Act_F_Type); 11269 11270 -- If the formal is controlling, then the 11271 -- the type of the actual primitive's formal 11272 -- must be derived directly or indirectly 11273 -- from the type of the ancestor primitive's 11274 -- formal. 11275 11276 if Is_Controlling_Formal (Anc_Formal) then 11277 if not Is_Tagged_Ancestor 11278 (Anc_F_Type, Act_F_Type) 11279 then 11280 exit; 11281 end if; 11282 11283 -- Otherwise the types of the formals must 11284 -- be the same. 11285 11286 elsif Anc_F_Type /= Act_F_Type then 11287 exit; 11288 end if; 11289 11290 Next_Entity (Anc_Formal); 11291 Next_Entity (Act_Formal); 11292 end loop; 11293 11294 -- If we traversed through all of the formals 11295 -- then so far the subprograms correspond, so 11296 -- now check that any result types correspond. 11297 11298 if No (Anc_Formal) and then No (Act_Formal) then 11299 Subprograms_Correspond := True; 11300 11301 if Ekind (Act_Subp) = E_Function then 11302 Anc_F_Type := Etype (Anc_Subp); 11303 Act_F_Type := Etype (Act_Subp); 11304 11305 if Ekind (Anc_F_Type) 11306 = E_Anonymous_Access_Type 11307 then 11308 Anc_F_Type := 11309 Designated_Type (Anc_F_Type); 11310 11311 if Ekind (Act_F_Type) 11312 = E_Anonymous_Access_Type 11313 then 11314 Act_F_Type := 11315 Designated_Type (Act_F_Type); 11316 else 11317 Subprograms_Correspond := False; 11318 end if; 11319 11320 elsif 11321 Ekind (Act_F_Type) 11322 = E_Anonymous_Access_Type 11323 then 11324 Subprograms_Correspond := False; 11325 end if; 11326 11327 Anc_F_Type := Base_Type (Anc_F_Type); 11328 Act_F_Type := Base_Type (Act_F_Type); 11329 11330 -- Now either the result types must be 11331 -- the same or, if the result type is 11332 -- controlling, the result type of the 11333 -- actual primitive must descend from the 11334 -- result type of the ancestor primitive. 11335 11336 if Subprograms_Correspond 11337 and then Anc_F_Type /= Act_F_Type 11338 and then 11339 Has_Controlling_Result (Anc_Subp) 11340 and then 11341 not Is_Tagged_Ancestor 11342 (Anc_F_Type, Act_F_Type) 11343 then 11344 Subprograms_Correspond := False; 11345 end if; 11346 end if; 11347 11348 -- Found a matching subprogram belonging to 11349 -- formal ancestor type, so actual subprogram 11350 -- corresponds and this violates 3.9.3(9). 11351 11352 if Subprograms_Correspond then 11353 Error_Msg_NE 11354 ("abstract subprogram & overrides " & 11355 "nonabstract subprogram of ancestor", 11356 Actual, 11357 Act_Subp); 11358 end if; 11359 end if; 11360 end if; 11361 end if; 11362 11363 Next_Elmt (Act_Elmt); 11364 end loop; 11365 end if; 11366 11367 Next_Elmt (Gen_Elmt); 11368 end loop; 11369 end Check_Abstract_Primitives; 11370 end if; 11371 11372 -- Verify that limitedness matches. If parent is a limited 11373 -- interface then the generic formal is not unless declared 11374 -- explicitly so. If not declared limited, the actual cannot be 11375 -- limited (see AI05-0087). 11376 11377 -- Even though this AI is a binding interpretation, we enable the 11378 -- check only in Ada 2012 mode, because this improper construct 11379 -- shows up in user code and in existing B-tests. 11380 11381 if Is_Limited_Type (Act_T) 11382 and then not Is_Limited_Type (A_Gen_T) 11383 and then Ada_Version >= Ada_2012 11384 then 11385 if In_Instance then 11386 null; 11387 else 11388 Error_Msg_NE 11389 ("actual for non-limited & cannot be a limited type", Actual, 11390 Gen_T); 11391 Explain_Limited_Type (Act_T, Actual); 11392 Abandon_Instantiation (Actual); 11393 end if; 11394 end if; 11395 end Validate_Derived_Type_Instance; 11396 11397 ---------------------------------------- 11398 -- Validate_Discriminated_Formal_Type -- 11399 ---------------------------------------- 11400 11401 procedure Validate_Discriminated_Formal_Type is 11402 Formal_Discr : Entity_Id; 11403 Actual_Discr : Entity_Id; 11404 Formal_Subt : Entity_Id; 11405 11406 begin 11407 if Has_Discriminants (A_Gen_T) then 11408 if not Has_Discriminants (Act_T) then 11409 Error_Msg_NE 11410 ("actual for & must have discriminants", Actual, Gen_T); 11411 Abandon_Instantiation (Actual); 11412 11413 elsif Is_Constrained (Act_T) then 11414 Error_Msg_NE 11415 ("actual for & must be unconstrained", Actual, Gen_T); 11416 Abandon_Instantiation (Actual); 11417 11418 else 11419 Formal_Discr := First_Discriminant (A_Gen_T); 11420 Actual_Discr := First_Discriminant (Act_T); 11421 while Formal_Discr /= Empty loop 11422 if Actual_Discr = Empty then 11423 Error_Msg_NE 11424 ("discriminants on actual do not match formal", 11425 Actual, Gen_T); 11426 Abandon_Instantiation (Actual); 11427 end if; 11428 11429 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 11430 11431 -- Access discriminants match if designated types do 11432 11433 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 11434 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 11435 E_Anonymous_Access_Type 11436 and then 11437 Get_Instance_Of 11438 (Designated_Type (Base_Type (Formal_Subt))) = 11439 Designated_Type (Base_Type (Etype (Actual_Discr))) 11440 then 11441 null; 11442 11443 elsif Base_Type (Formal_Subt) /= 11444 Base_Type (Etype (Actual_Discr)) 11445 then 11446 Error_Msg_NE 11447 ("types of actual discriminants must match formal", 11448 Actual, Gen_T); 11449 Abandon_Instantiation (Actual); 11450 11451 elsif not Subtypes_Statically_Match 11452 (Formal_Subt, Etype (Actual_Discr)) 11453 and then Ada_Version >= Ada_95 11454 then 11455 Error_Msg_NE 11456 ("subtypes of actual discriminants must match formal", 11457 Actual, Gen_T); 11458 Abandon_Instantiation (Actual); 11459 end if; 11460 11461 Next_Discriminant (Formal_Discr); 11462 Next_Discriminant (Actual_Discr); 11463 end loop; 11464 11465 if Actual_Discr /= Empty then 11466 Error_Msg_NE 11467 ("discriminants on actual do not match formal", 11468 Actual, Gen_T); 11469 Abandon_Instantiation (Actual); 11470 end if; 11471 end if; 11472 end if; 11473 end Validate_Discriminated_Formal_Type; 11474 11475 --------------------------------------- 11476 -- Validate_Incomplete_Type_Instance -- 11477 --------------------------------------- 11478 11479 procedure Validate_Incomplete_Type_Instance is 11480 begin 11481 if not Is_Tagged_Type (Act_T) 11482 and then Is_Tagged_Type (A_Gen_T) 11483 then 11484 Error_Msg_NE 11485 ("actual for & must be a tagged type", Actual, Gen_T); 11486 end if; 11487 11488 Validate_Discriminated_Formal_Type; 11489 end Validate_Incomplete_Type_Instance; 11490 11491 -------------------------------------- 11492 -- Validate_Interface_Type_Instance -- 11493 -------------------------------------- 11494 11495 procedure Validate_Interface_Type_Instance is 11496 begin 11497 if not Is_Interface (Act_T) then 11498 Error_Msg_NE 11499 ("actual for formal interface type must be an interface", 11500 Actual, Gen_T); 11501 11502 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 11503 or else 11504 Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 11505 or else 11506 Is_Protected_Interface (A_Gen_T) /= 11507 Is_Protected_Interface (Act_T) 11508 or else 11509 Is_Synchronized_Interface (A_Gen_T) /= 11510 Is_Synchronized_Interface (Act_T) 11511 then 11512 Error_Msg_NE 11513 ("actual for interface& does not match (RM 12.5.5(4))", 11514 Actual, Gen_T); 11515 end if; 11516 end Validate_Interface_Type_Instance; 11517 11518 ------------------------------------ 11519 -- Validate_Private_Type_Instance -- 11520 ------------------------------------ 11521 11522 procedure Validate_Private_Type_Instance is 11523 begin 11524 if Is_Limited_Type (Act_T) 11525 and then not Is_Limited_Type (A_Gen_T) 11526 then 11527 if In_Instance then 11528 null; 11529 else 11530 Error_Msg_NE 11531 ("actual for non-limited & cannot be a limited type", Actual, 11532 Gen_T); 11533 Explain_Limited_Type (Act_T, Actual); 11534 Abandon_Instantiation (Actual); 11535 end if; 11536 11537 elsif Known_To_Have_Preelab_Init (A_Gen_T) 11538 and then not Has_Preelaborable_Initialization (Act_T) 11539 then 11540 Error_Msg_NE 11541 ("actual for & must have preelaborable initialization", Actual, 11542 Gen_T); 11543 11544 elsif Is_Indefinite_Subtype (Act_T) 11545 and then not Is_Indefinite_Subtype (A_Gen_T) 11546 and then Ada_Version >= Ada_95 11547 then 11548 Error_Msg_NE 11549 ("actual for & must be a definite subtype", Actual, Gen_T); 11550 11551 elsif not Is_Tagged_Type (Act_T) 11552 and then Is_Tagged_Type (A_Gen_T) 11553 then 11554 Error_Msg_NE 11555 ("actual for & must be a tagged type", Actual, Gen_T); 11556 end if; 11557 11558 Validate_Discriminated_Formal_Type; 11559 Ancestor := Gen_T; 11560 end Validate_Private_Type_Instance; 11561 11562 -- Start of processing for Instantiate_Type 11563 11564 begin 11565 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 11566 Error_Msg_N ("duplicate instantiation of generic type", Actual); 11567 return New_List (Error); 11568 11569 elsif not Is_Entity_Name (Actual) 11570 or else not Is_Type (Entity (Actual)) 11571 then 11572 Error_Msg_NE 11573 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 11574 Abandon_Instantiation (Actual); 11575 11576 else 11577 Act_T := Entity (Actual); 11578 11579 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 11580 -- as a generic actual parameter if the corresponding formal type 11581 -- does not have a known_discriminant_part, or is a formal derived 11582 -- type that is an Unchecked_Union type. 11583 11584 if Is_Unchecked_Union (Base_Type (Act_T)) then 11585 if not Has_Discriminants (A_Gen_T) 11586 or else 11587 (Is_Derived_Type (A_Gen_T) 11588 and then 11589 Is_Unchecked_Union (A_Gen_T)) 11590 then 11591 null; 11592 else 11593 Error_Msg_N ("unchecked union cannot be the actual for a" & 11594 " discriminated formal type", Act_T); 11595 11596 end if; 11597 end if; 11598 11599 -- Deal with fixed/floating restrictions 11600 11601 if Is_Floating_Point_Type (Act_T) then 11602 Check_Restriction (No_Floating_Point, Actual); 11603 elsif Is_Fixed_Point_Type (Act_T) then 11604 Check_Restriction (No_Fixed_Point, Actual); 11605 end if; 11606 11607 -- Deal with error of using incomplete type as generic actual. 11608 -- This includes limited views of a type, even if the non-limited 11609 -- view may be available. 11610 11611 if Ekind (Act_T) = E_Incomplete_Type 11612 or else (Is_Class_Wide_Type (Act_T) 11613 and then 11614 Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 11615 then 11616 -- If the formal is an incomplete type, the actual can be 11617 -- incomplete as well. 11618 11619 if Ekind (A_Gen_T) = E_Incomplete_Type then 11620 null; 11621 11622 elsif Is_Class_Wide_Type (Act_T) 11623 or else No (Full_View (Act_T)) 11624 then 11625 Error_Msg_N ("premature use of incomplete type", Actual); 11626 Abandon_Instantiation (Actual); 11627 else 11628 Act_T := Full_View (Act_T); 11629 Set_Entity (Actual, Act_T); 11630 11631 if Has_Private_Component (Act_T) then 11632 Error_Msg_N 11633 ("premature use of type with private component", Actual); 11634 end if; 11635 end if; 11636 11637 -- Deal with error of premature use of private type as generic actual 11638 11639 elsif Is_Private_Type (Act_T) 11640 and then Is_Private_Type (Base_Type (Act_T)) 11641 and then not Is_Generic_Type (Act_T) 11642 and then not Is_Derived_Type (Act_T) 11643 and then No (Full_View (Root_Type (Act_T))) 11644 then 11645 -- If the formal is an incomplete type, the actual can be 11646 -- private or incomplete as well. 11647 11648 if Ekind (A_Gen_T) = E_Incomplete_Type then 11649 null; 11650 else 11651 Error_Msg_N ("premature use of private type", Actual); 11652 end if; 11653 11654 elsif Has_Private_Component (Act_T) then 11655 Error_Msg_N 11656 ("premature use of type with private component", Actual); 11657 end if; 11658 11659 Set_Instance_Of (A_Gen_T, Act_T); 11660 11661 -- If the type is generic, the class-wide type may also be used 11662 11663 if Is_Tagged_Type (A_Gen_T) 11664 and then Is_Tagged_Type (Act_T) 11665 and then not Is_Class_Wide_Type (A_Gen_T) 11666 then 11667 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 11668 Class_Wide_Type (Act_T)); 11669 end if; 11670 11671 if not Is_Abstract_Type (A_Gen_T) 11672 and then Is_Abstract_Type (Act_T) 11673 then 11674 Error_Msg_N 11675 ("actual of non-abstract formal cannot be abstract", Actual); 11676 end if; 11677 11678 -- A generic scalar type is a first subtype for which we generate 11679 -- an anonymous base type. Indicate that the instance of this base 11680 -- is the base type of the actual. 11681 11682 if Is_Scalar_Type (A_Gen_T) then 11683 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 11684 end if; 11685 end if; 11686 11687 if Error_Posted (Act_T) then 11688 null; 11689 else 11690 case Nkind (Def) is 11691 when N_Formal_Private_Type_Definition => 11692 Validate_Private_Type_Instance; 11693 11694 when N_Formal_Incomplete_Type_Definition => 11695 Validate_Incomplete_Type_Instance; 11696 11697 when N_Formal_Derived_Type_Definition => 11698 Validate_Derived_Type_Instance; 11699 11700 when N_Formal_Discrete_Type_Definition => 11701 if not Is_Discrete_Type (Act_T) then 11702 Error_Msg_NE 11703 ("expect discrete type in instantiation of&", 11704 Actual, Gen_T); 11705 Abandon_Instantiation (Actual); 11706 end if; 11707 11708 when N_Formal_Signed_Integer_Type_Definition => 11709 if not Is_Signed_Integer_Type (Act_T) then 11710 Error_Msg_NE 11711 ("expect signed integer type in instantiation of&", 11712 Actual, Gen_T); 11713 Abandon_Instantiation (Actual); 11714 end if; 11715 11716 when N_Formal_Modular_Type_Definition => 11717 if not Is_Modular_Integer_Type (Act_T) then 11718 Error_Msg_NE 11719 ("expect modular type in instantiation of &", 11720 Actual, Gen_T); 11721 Abandon_Instantiation (Actual); 11722 end if; 11723 11724 when N_Formal_Floating_Point_Definition => 11725 if not Is_Floating_Point_Type (Act_T) then 11726 Error_Msg_NE 11727 ("expect float type in instantiation of &", Actual, Gen_T); 11728 Abandon_Instantiation (Actual); 11729 end if; 11730 11731 when N_Formal_Ordinary_Fixed_Point_Definition => 11732 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 11733 Error_Msg_NE 11734 ("expect ordinary fixed point type in instantiation of &", 11735 Actual, Gen_T); 11736 Abandon_Instantiation (Actual); 11737 end if; 11738 11739 when N_Formal_Decimal_Fixed_Point_Definition => 11740 if not Is_Decimal_Fixed_Point_Type (Act_T) then 11741 Error_Msg_NE 11742 ("expect decimal type in instantiation of &", 11743 Actual, Gen_T); 11744 Abandon_Instantiation (Actual); 11745 end if; 11746 11747 when N_Array_Type_Definition => 11748 Validate_Array_Type_Instance; 11749 11750 when N_Access_To_Object_Definition => 11751 Validate_Access_Type_Instance; 11752 11753 when N_Access_Function_Definition | 11754 N_Access_Procedure_Definition => 11755 Validate_Access_Subprogram_Instance; 11756 11757 when N_Record_Definition => 11758 Validate_Interface_Type_Instance; 11759 11760 when N_Derived_Type_Definition => 11761 Validate_Derived_Interface_Type_Instance; 11762 11763 when others => 11764 raise Program_Error; 11765 11766 end case; 11767 end if; 11768 11769 Subt := New_Copy (Gen_T); 11770 11771 -- Use adjusted sloc of subtype name as the location for other nodes in 11772 -- the subtype declaration. 11773 11774 Loc := Sloc (Subt); 11775 11776 Decl_Node := 11777 Make_Subtype_Declaration (Loc, 11778 Defining_Identifier => Subt, 11779 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); 11780 11781 if Is_Private_Type (Act_T) then 11782 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 11783 11784 elsif Is_Access_Type (Act_T) 11785 and then Is_Private_Type (Designated_Type (Act_T)) 11786 then 11787 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 11788 end if; 11789 11790 Decl_Nodes := New_List (Decl_Node); 11791 11792 -- Flag actual derived types so their elaboration produces the 11793 -- appropriate renamings for the primitive operations of the ancestor. 11794 -- Flag actual for formal private types as well, to determine whether 11795 -- operations in the private part may override inherited operations. 11796 -- If the formal has an interface list, the ancestor is not the 11797 -- parent, but the analyzed formal that includes the interface 11798 -- operations of all its progenitors. 11799 11800 -- Same treatment for formal private types, so we can check whether the 11801 -- type is tagged limited when validating derivations in the private 11802 -- part. (See AI05-096). 11803 11804 if Nkind (Def) = N_Formal_Derived_Type_Definition then 11805 if Present (Interface_List (Def)) then 11806 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 11807 else 11808 Set_Generic_Parent_Type (Decl_Node, Ancestor); 11809 end if; 11810 11811 elsif Nkind_In (Def, 11812 N_Formal_Private_Type_Definition, 11813 N_Formal_Incomplete_Type_Definition) 11814 then 11815 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 11816 end if; 11817 11818 -- If the actual is a synchronized type that implements an interface, 11819 -- the primitive operations are attached to the corresponding record, 11820 -- and we have to treat it as an additional generic actual, so that its 11821 -- primitive operations become visible in the instance. The task or 11822 -- protected type itself does not carry primitive operations. 11823 11824 if Is_Concurrent_Type (Act_T) 11825 and then Is_Tagged_Type (Act_T) 11826 and then Present (Corresponding_Record_Type (Act_T)) 11827 and then Present (Ancestor) 11828 and then Is_Interface (Ancestor) 11829 then 11830 declare 11831 Corr_Rec : constant Entity_Id := 11832 Corresponding_Record_Type (Act_T); 11833 New_Corr : Entity_Id; 11834 Corr_Decl : Node_Id; 11835 11836 begin 11837 New_Corr := Make_Temporary (Loc, 'S'); 11838 Corr_Decl := 11839 Make_Subtype_Declaration (Loc, 11840 Defining_Identifier => New_Corr, 11841 Subtype_Indication => 11842 New_Occurrence_Of (Corr_Rec, Loc)); 11843 Append_To (Decl_Nodes, Corr_Decl); 11844 11845 if Ekind (Act_T) = E_Task_Type then 11846 Set_Ekind (Subt, E_Task_Subtype); 11847 else 11848 Set_Ekind (Subt, E_Protected_Subtype); 11849 end if; 11850 11851 Set_Corresponding_Record_Type (Subt, Corr_Rec); 11852 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 11853 Set_Generic_Parent_Type (Decl_Node, Empty); 11854 end; 11855 end if; 11856 11857 return Decl_Nodes; 11858 end Instantiate_Type; 11859 11860 --------------------- 11861 -- Is_In_Main_Unit -- 11862 --------------------- 11863 11864 function Is_In_Main_Unit (N : Node_Id) return Boolean is 11865 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 11866 Current_Unit : Node_Id; 11867 11868 begin 11869 if Unum = Main_Unit then 11870 return True; 11871 11872 -- If the current unit is a subunit then it is either the main unit or 11873 -- is being compiled as part of the main unit. 11874 11875 elsif Nkind (N) = N_Compilation_Unit then 11876 return Nkind (Unit (N)) = N_Subunit; 11877 end if; 11878 11879 Current_Unit := Parent (N); 11880 while Present (Current_Unit) 11881 and then Nkind (Current_Unit) /= N_Compilation_Unit 11882 loop 11883 Current_Unit := Parent (Current_Unit); 11884 end loop; 11885 11886 -- The instantiation node is in the main unit, or else the current node 11887 -- (perhaps as the result of nested instantiations) is in the main unit, 11888 -- or in the declaration of the main unit, which in this last case must 11889 -- be a body. 11890 11891 return Unum = Main_Unit 11892 or else Current_Unit = Cunit (Main_Unit) 11893 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 11894 or else (Present (Library_Unit (Current_Unit)) 11895 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 11896 end Is_In_Main_Unit; 11897 11898 ---------------------------- 11899 -- Load_Parent_Of_Generic -- 11900 ---------------------------- 11901 11902 procedure Load_Parent_Of_Generic 11903 (N : Node_Id; 11904 Spec : Node_Id; 11905 Body_Optional : Boolean := False) 11906 is 11907 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 11908 Saved_Style_Check : constant Boolean := Style_Check; 11909 Saved_Warnings : constant Warning_Record := Save_Warnings; 11910 True_Parent : Node_Id; 11911 Inst_Node : Node_Id; 11912 OK : Boolean; 11913 Previous_Instances : constant Elist_Id := New_Elmt_List; 11914 11915 procedure Collect_Previous_Instances (Decls : List_Id); 11916 -- Collect all instantiations in the given list of declarations, that 11917 -- precede the generic that we need to load. If the bodies of these 11918 -- instantiations are available, we must analyze them, to ensure that 11919 -- the public symbols generated are the same when the unit is compiled 11920 -- to generate code, and when it is compiled in the context of a unit 11921 -- that needs a particular nested instance. This process is applied to 11922 -- both package and subprogram instances. 11923 11924 -------------------------------- 11925 -- Collect_Previous_Instances -- 11926 -------------------------------- 11927 11928 procedure Collect_Previous_Instances (Decls : List_Id) is 11929 Decl : Node_Id; 11930 11931 begin 11932 Decl := First (Decls); 11933 while Present (Decl) loop 11934 if Sloc (Decl) >= Sloc (Inst_Node) then 11935 return; 11936 11937 -- If Decl is an instantiation, then record it as requiring 11938 -- instantiation of the corresponding body, except if it is an 11939 -- abbreviated instantiation generated internally for conformance 11940 -- checking purposes only for the case of a formal package 11941 -- declared without a box (see Instantiate_Formal_Package). Such 11942 -- an instantiation does not generate any code (the actual code 11943 -- comes from actual) and thus does not need to be analyzed here. 11944 -- If the instantiation appears with a generic package body it is 11945 -- not analyzed here either. 11946 11947 elsif Nkind (Decl) = N_Package_Instantiation 11948 and then not Is_Internal (Defining_Entity (Decl)) 11949 then 11950 Append_Elmt (Decl, Previous_Instances); 11951 11952 -- For a subprogram instantiation, omit instantiations intrinsic 11953 -- operations (Unchecked_Conversions, etc.) that have no bodies. 11954 11955 elsif Nkind_In (Decl, N_Function_Instantiation, 11956 N_Procedure_Instantiation) 11957 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 11958 then 11959 Append_Elmt (Decl, Previous_Instances); 11960 11961 elsif Nkind (Decl) = N_Package_Declaration then 11962 Collect_Previous_Instances 11963 (Visible_Declarations (Specification (Decl))); 11964 Collect_Previous_Instances 11965 (Private_Declarations (Specification (Decl))); 11966 11967 -- Previous non-generic bodies may contain instances as well 11968 11969 elsif Nkind (Decl) = N_Package_Body 11970 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 11971 then 11972 Collect_Previous_Instances (Declarations (Decl)); 11973 11974 elsif Nkind (Decl) = N_Subprogram_Body 11975 and then not Acts_As_Spec (Decl) 11976 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 11977 then 11978 Collect_Previous_Instances (Declarations (Decl)); 11979 end if; 11980 11981 Next (Decl); 11982 end loop; 11983 end Collect_Previous_Instances; 11984 11985 -- Start of processing for Load_Parent_Of_Generic 11986 11987 begin 11988 if not In_Same_Source_Unit (N, Spec) 11989 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 11990 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 11991 and then not Is_In_Main_Unit (Spec)) 11992 then 11993 -- Find body of parent of spec, and analyze it. A special case arises 11994 -- when the parent is an instantiation, that is to say when we are 11995 -- currently instantiating a nested generic. In that case, there is 11996 -- no separate file for the body of the enclosing instance. Instead, 11997 -- the enclosing body must be instantiated as if it were a pending 11998 -- instantiation, in order to produce the body for the nested generic 11999 -- we require now. Note that in that case the generic may be defined 12000 -- in a package body, the instance defined in the same package body, 12001 -- and the original enclosing body may not be in the main unit. 12002 12003 Inst_Node := Empty; 12004 12005 True_Parent := Parent (Spec); 12006 while Present (True_Parent) 12007 and then Nkind (True_Parent) /= N_Compilation_Unit 12008 loop 12009 if Nkind (True_Parent) = N_Package_Declaration 12010 and then 12011 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 12012 then 12013 -- Parent is a compilation unit that is an instantiation. 12014 -- Instantiation node has been replaced with package decl. 12015 12016 Inst_Node := Original_Node (True_Parent); 12017 exit; 12018 12019 elsif Nkind (True_Parent) = N_Package_Declaration 12020 and then Present (Generic_Parent (Specification (True_Parent))) 12021 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 12022 then 12023 -- Parent is an instantiation within another specification. 12024 -- Declaration for instance has been inserted before original 12025 -- instantiation node. A direct link would be preferable? 12026 12027 Inst_Node := Next (True_Parent); 12028 while Present (Inst_Node) 12029 and then Nkind (Inst_Node) /= N_Package_Instantiation 12030 loop 12031 Next (Inst_Node); 12032 end loop; 12033 12034 -- If the instance appears within a generic, and the generic 12035 -- unit is defined within a formal package of the enclosing 12036 -- generic, there is no generic body available, and none 12037 -- needed. A more precise test should be used ??? 12038 12039 if No (Inst_Node) then 12040 return; 12041 end if; 12042 12043 exit; 12044 12045 else 12046 True_Parent := Parent (True_Parent); 12047 end if; 12048 end loop; 12049 12050 -- Case where we are currently instantiating a nested generic 12051 12052 if Present (Inst_Node) then 12053 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 12054 12055 -- Instantiation node and declaration of instantiated package 12056 -- were exchanged when only the declaration was needed. 12057 -- Restore instantiation node before proceeding with body. 12058 12059 Set_Unit (Parent (True_Parent), Inst_Node); 12060 end if; 12061 12062 -- Now complete instantiation of enclosing body, if it appears in 12063 -- some other unit. If it appears in the current unit, the body 12064 -- will have been instantiated already. 12065 12066 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 12067 12068 -- We need to determine the expander mode to instantiate the 12069 -- enclosing body. Because the generic body we need may use 12070 -- global entities declared in the enclosing package (including 12071 -- aggregates) it is in general necessary to compile this body 12072 -- with expansion enabled, except if we are within a generic 12073 -- package, in which case the usual generic rule applies. 12074 12075 declare 12076 Exp_Status : Boolean := True; 12077 Scop : Entity_Id; 12078 12079 begin 12080 -- Loop through scopes looking for generic package 12081 12082 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 12083 while Present (Scop) 12084 and then Scop /= Standard_Standard 12085 loop 12086 if Ekind (Scop) = E_Generic_Package then 12087 Exp_Status := False; 12088 exit; 12089 end if; 12090 12091 Scop := Scope (Scop); 12092 end loop; 12093 12094 -- Collect previous instantiations in the unit that contains 12095 -- the desired generic. 12096 12097 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 12098 and then not Body_Optional 12099 then 12100 declare 12101 Decl : Elmt_Id; 12102 Info : Pending_Body_Info; 12103 Par : Node_Id; 12104 12105 begin 12106 Par := Parent (Inst_Node); 12107 while Present (Par) loop 12108 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 12109 Par := Parent (Par); 12110 end loop; 12111 12112 pragma Assert (Present (Par)); 12113 12114 if Nkind (Par) = N_Package_Body then 12115 Collect_Previous_Instances (Declarations (Par)); 12116 12117 elsif Nkind (Par) = N_Package_Declaration then 12118 Collect_Previous_Instances 12119 (Visible_Declarations (Specification (Par))); 12120 Collect_Previous_Instances 12121 (Private_Declarations (Specification (Par))); 12122 12123 else 12124 -- Enclosing unit is a subprogram body. In this 12125 -- case all instance bodies are processed in order 12126 -- and there is no need to collect them separately. 12127 12128 null; 12129 end if; 12130 12131 Decl := First_Elmt (Previous_Instances); 12132 while Present (Decl) loop 12133 Info := 12134 (Inst_Node => Node (Decl), 12135 Act_Decl => 12136 Instance_Spec (Node (Decl)), 12137 Expander_Status => Exp_Status, 12138 Current_Sem_Unit => 12139 Get_Code_Unit (Sloc (Node (Decl))), 12140 Scope_Suppress => Scope_Suppress, 12141 Local_Suppress_Stack_Top => 12142 Local_Suppress_Stack_Top, 12143 Version => Ada_Version, 12144 Version_Pragma => Ada_Version_Pragma, 12145 Warnings => Save_Warnings, 12146 SPARK_Mode => SPARK_Mode, 12147 SPARK_Mode_Pragma => SPARK_Mode_Pragma); 12148 12149 -- Package instance 12150 12151 if 12152 Nkind (Node (Decl)) = N_Package_Instantiation 12153 then 12154 Instantiate_Package_Body 12155 (Info, Body_Optional => True); 12156 12157 -- Subprogram instance 12158 12159 else 12160 -- The instance_spec is the wrapper package, 12161 -- and the subprogram declaration is the last 12162 -- declaration in the wrapper. 12163 12164 Info.Act_Decl := 12165 Last 12166 (Visible_Declarations 12167 (Specification (Info.Act_Decl))); 12168 12169 Instantiate_Subprogram_Body 12170 (Info, Body_Optional => True); 12171 end if; 12172 12173 Next_Elmt (Decl); 12174 end loop; 12175 end; 12176 end if; 12177 12178 Instantiate_Package_Body 12179 (Body_Info => 12180 ((Inst_Node => Inst_Node, 12181 Act_Decl => True_Parent, 12182 Expander_Status => Exp_Status, 12183 Current_Sem_Unit => Get_Code_Unit 12184 (Sloc (Inst_Node)), 12185 Scope_Suppress => Scope_Suppress, 12186 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 12187 Version => Ada_Version, 12188 Version_Pragma => Ada_Version_Pragma, 12189 Warnings => Save_Warnings, 12190 SPARK_Mode => SPARK_Mode, 12191 SPARK_Mode_Pragma => SPARK_Mode_Pragma)), 12192 Body_Optional => Body_Optional); 12193 end; 12194 end if; 12195 12196 -- Case where we are not instantiating a nested generic 12197 12198 else 12199 Opt.Style_Check := False; 12200 Expander_Mode_Save_And_Set (True); 12201 Load_Needed_Body (Comp_Unit, OK); 12202 Opt.Style_Check := Saved_Style_Check; 12203 Restore_Warnings (Saved_Warnings); 12204 Expander_Mode_Restore; 12205 12206 if not OK 12207 and then Unit_Requires_Body (Defining_Entity (Spec)) 12208 and then not Body_Optional 12209 then 12210 declare 12211 Bname : constant Unit_Name_Type := 12212 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 12213 12214 begin 12215 -- In CodePeer mode, the missing body may make the analysis 12216 -- incomplete, but we do not treat it as fatal. 12217 12218 if CodePeer_Mode then 12219 return; 12220 12221 else 12222 Error_Msg_Unit_1 := Bname; 12223 Error_Msg_N ("this instantiation requires$!", N); 12224 Error_Msg_File_1 := 12225 Get_File_Name (Bname, Subunit => False); 12226 Error_Msg_N ("\but file{ was not found!", N); 12227 raise Unrecoverable_Error; 12228 end if; 12229 end; 12230 end if; 12231 end if; 12232 end if; 12233 12234 -- If loading parent of the generic caused an instantiation circularity, 12235 -- we abandon compilation at this point, because otherwise in some cases 12236 -- we get into trouble with infinite recursions after this point. 12237 12238 if Circularity_Detected then 12239 raise Unrecoverable_Error; 12240 end if; 12241 end Load_Parent_Of_Generic; 12242 12243 --------------------------------- 12244 -- Map_Formal_Package_Entities -- 12245 --------------------------------- 12246 12247 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 12248 E1 : Entity_Id; 12249 E2 : Entity_Id; 12250 12251 begin 12252 Set_Instance_Of (Form, Act); 12253 12254 -- Traverse formal and actual package to map the corresponding entities. 12255 -- We skip over internal entities that may be generated during semantic 12256 -- analysis, and find the matching entities by name, given that they 12257 -- must appear in the same order. 12258 12259 E1 := First_Entity (Form); 12260 E2 := First_Entity (Act); 12261 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 12262 -- Could this test be a single condition??? Seems like it could, and 12263 -- isn't FPE (Form) a constant anyway??? 12264 12265 if not Is_Internal (E1) 12266 and then Present (Parent (E1)) 12267 and then not Is_Class_Wide_Type (E1) 12268 and then not Is_Internal_Name (Chars (E1)) 12269 then 12270 while Present (E2) and then Chars (E2) /= Chars (E1) loop 12271 Next_Entity (E2); 12272 end loop; 12273 12274 if No (E2) then 12275 exit; 12276 else 12277 Set_Instance_Of (E1, E2); 12278 12279 if Is_Type (E1) and then Is_Tagged_Type (E2) then 12280 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 12281 end if; 12282 12283 if Is_Constrained (E1) then 12284 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 12285 end if; 12286 12287 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 12288 Map_Formal_Package_Entities (E1, E2); 12289 end if; 12290 end if; 12291 end if; 12292 12293 Next_Entity (E1); 12294 end loop; 12295 end Map_Formal_Package_Entities; 12296 12297 ----------------------- 12298 -- Move_Freeze_Nodes -- 12299 ----------------------- 12300 12301 procedure Move_Freeze_Nodes 12302 (Out_Of : Entity_Id; 12303 After : Node_Id; 12304 L : List_Id) 12305 is 12306 Decl : Node_Id; 12307 Next_Decl : Node_Id; 12308 Next_Node : Node_Id := After; 12309 Spec : Node_Id; 12310 12311 function Is_Outer_Type (T : Entity_Id) return Boolean; 12312 -- Check whether entity is declared in a scope external to that of the 12313 -- generic unit. 12314 12315 ------------------- 12316 -- Is_Outer_Type -- 12317 ------------------- 12318 12319 function Is_Outer_Type (T : Entity_Id) return Boolean is 12320 Scop : Entity_Id := Scope (T); 12321 12322 begin 12323 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 12324 return True; 12325 12326 else 12327 while Scop /= Standard_Standard loop 12328 if Scop = Out_Of then 12329 return False; 12330 else 12331 Scop := Scope (Scop); 12332 end if; 12333 end loop; 12334 12335 return True; 12336 end if; 12337 end Is_Outer_Type; 12338 12339 -- Start of processing for Move_Freeze_Nodes 12340 12341 begin 12342 if No (L) then 12343 return; 12344 end if; 12345 12346 -- First remove the freeze nodes that may appear before all other 12347 -- declarations. 12348 12349 Decl := First (L); 12350 while Present (Decl) 12351 and then Nkind (Decl) = N_Freeze_Entity 12352 and then Is_Outer_Type (Entity (Decl)) 12353 loop 12354 Decl := Remove_Head (L); 12355 Insert_After (Next_Node, Decl); 12356 Set_Analyzed (Decl, False); 12357 Next_Node := Decl; 12358 Decl := First (L); 12359 end loop; 12360 12361 -- Next scan the list of declarations and remove each freeze node that 12362 -- appears ahead of the current node. 12363 12364 while Present (Decl) loop 12365 while Present (Next (Decl)) 12366 and then Nkind (Next (Decl)) = N_Freeze_Entity 12367 and then Is_Outer_Type (Entity (Next (Decl))) 12368 loop 12369 Next_Decl := Remove_Next (Decl); 12370 Insert_After (Next_Node, Next_Decl); 12371 Set_Analyzed (Next_Decl, False); 12372 Next_Node := Next_Decl; 12373 end loop; 12374 12375 -- If the declaration is a nested package or concurrent type, then 12376 -- recurse. Nested generic packages will have been processed from the 12377 -- inside out. 12378 12379 case Nkind (Decl) is 12380 when N_Package_Declaration => 12381 Spec := Specification (Decl); 12382 12383 when N_Task_Type_Declaration => 12384 Spec := Task_Definition (Decl); 12385 12386 when N_Protected_Type_Declaration => 12387 Spec := Protected_Definition (Decl); 12388 12389 when others => 12390 Spec := Empty; 12391 end case; 12392 12393 if Present (Spec) then 12394 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 12395 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 12396 end if; 12397 12398 Next (Decl); 12399 end loop; 12400 end Move_Freeze_Nodes; 12401 12402 ---------------- 12403 -- Next_Assoc -- 12404 ---------------- 12405 12406 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 12407 begin 12408 return Generic_Renamings.Table (E).Next_In_HTable; 12409 end Next_Assoc; 12410 12411 ------------------------ 12412 -- Preanalyze_Actuals -- 12413 ------------------------ 12414 12415 procedure Preanalyze_Actuals (N : Node_Id) is 12416 Assoc : Node_Id; 12417 Act : Node_Id; 12418 Errs : constant Int := Serious_Errors_Detected; 12419 12420 Cur : Entity_Id := Empty; 12421 -- Current homograph of the instance name 12422 12423 Vis : Boolean; 12424 -- Saved visibility status of the current homograph 12425 12426 begin 12427 Assoc := First (Generic_Associations (N)); 12428 12429 -- If the instance is a child unit, its name may hide an outer homonym, 12430 -- so make it invisible to perform name resolution on the actuals. 12431 12432 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 12433 and then Present 12434 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 12435 then 12436 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 12437 12438 if Is_Compilation_Unit (Cur) then 12439 Vis := Is_Immediately_Visible (Cur); 12440 Set_Is_Immediately_Visible (Cur, False); 12441 else 12442 Cur := Empty; 12443 end if; 12444 end if; 12445 12446 while Present (Assoc) loop 12447 if Nkind (Assoc) /= N_Others_Choice then 12448 Act := Explicit_Generic_Actual_Parameter (Assoc); 12449 12450 -- Within a nested instantiation, a defaulted actual is an empty 12451 -- association, so nothing to analyze. If the subprogram actual 12452 -- is an attribute, analyze prefix only, because actual is not a 12453 -- complete attribute reference. 12454 12455 -- If actual is an allocator, analyze expression only. The full 12456 -- analysis can generate code, and if instance is a compilation 12457 -- unit we have to wait until the package instance is installed 12458 -- to have a proper place to insert this code. 12459 12460 -- String literals may be operators, but at this point we do not 12461 -- know whether the actual is a formal subprogram or a string. 12462 12463 if No (Act) then 12464 null; 12465 12466 elsif Nkind (Act) = N_Attribute_Reference then 12467 Analyze (Prefix (Act)); 12468 12469 elsif Nkind (Act) = N_Explicit_Dereference then 12470 Analyze (Prefix (Act)); 12471 12472 elsif Nkind (Act) = N_Allocator then 12473 declare 12474 Expr : constant Node_Id := Expression (Act); 12475 12476 begin 12477 if Nkind (Expr) = N_Subtype_Indication then 12478 Analyze (Subtype_Mark (Expr)); 12479 12480 -- Analyze separately each discriminant constraint, when 12481 -- given with a named association. 12482 12483 declare 12484 Constr : Node_Id; 12485 12486 begin 12487 Constr := First (Constraints (Constraint (Expr))); 12488 while Present (Constr) loop 12489 if Nkind (Constr) = N_Discriminant_Association then 12490 Analyze (Expression (Constr)); 12491 else 12492 Analyze (Constr); 12493 end if; 12494 12495 Next (Constr); 12496 end loop; 12497 end; 12498 12499 else 12500 Analyze (Expr); 12501 end if; 12502 end; 12503 12504 elsif Nkind (Act) /= N_Operator_Symbol then 12505 Analyze (Act); 12506 end if; 12507 12508 -- Ensure that a ghost subprogram does not act as generic actual 12509 12510 if Is_Entity_Name (Act) 12511 and then Is_Ghost_Subprogram (Entity (Act)) 12512 then 12513 Error_Msg_N 12514 ("ghost subprogram & cannot act as generic actual", Act); 12515 Abandon_Instantiation (Act); 12516 12517 elsif Errs /= Serious_Errors_Detected then 12518 12519 -- Do a minimal analysis of the generic, to prevent spurious 12520 -- warnings complaining about the generic being unreferenced, 12521 -- before abandoning the instantiation. 12522 12523 Analyze (Name (N)); 12524 12525 if Is_Entity_Name (Name (N)) 12526 and then Etype (Name (N)) /= Any_Type 12527 then 12528 Generate_Reference (Entity (Name (N)), Name (N)); 12529 Set_Is_Instantiated (Entity (Name (N))); 12530 end if; 12531 12532 if Present (Cur) then 12533 12534 -- For the case of a child instance hiding an outer homonym, 12535 -- provide additional warning which might explain the error. 12536 12537 Set_Is_Immediately_Visible (Cur, Vis); 12538 Error_Msg_NE ("& hides outer unit with the same name??", 12539 N, Defining_Unit_Name (N)); 12540 end if; 12541 12542 Abandon_Instantiation (Act); 12543 end if; 12544 end if; 12545 12546 Next (Assoc); 12547 end loop; 12548 12549 if Present (Cur) then 12550 Set_Is_Immediately_Visible (Cur, Vis); 12551 end if; 12552 end Preanalyze_Actuals; 12553 12554 ------------------- 12555 -- Remove_Parent -- 12556 ------------------- 12557 12558 procedure Remove_Parent (In_Body : Boolean := False) is 12559 S : Entity_Id := Current_Scope; 12560 -- S is the scope containing the instantiation just completed. The scope 12561 -- stack contains the parent instances of the instantiation, followed by 12562 -- the original S. 12563 12564 Cur_P : Entity_Id; 12565 E : Entity_Id; 12566 P : Entity_Id; 12567 Hidden : Elmt_Id; 12568 12569 begin 12570 -- After child instantiation is complete, remove from scope stack the 12571 -- extra copy of the current scope, and then remove parent instances. 12572 12573 if not In_Body then 12574 Pop_Scope; 12575 12576 while Current_Scope /= S loop 12577 P := Current_Scope; 12578 End_Package_Scope (Current_Scope); 12579 12580 if In_Open_Scopes (P) then 12581 E := First_Entity (P); 12582 while Present (E) loop 12583 Set_Is_Immediately_Visible (E, True); 12584 Next_Entity (E); 12585 end loop; 12586 12587 -- If instantiation is declared in a block, it is the enclosing 12588 -- scope that might be a parent instance. Note that only one 12589 -- block can be involved, because the parent instances have 12590 -- been installed within it. 12591 12592 if Ekind (P) = E_Block then 12593 Cur_P := Scope (P); 12594 else 12595 Cur_P := P; 12596 end if; 12597 12598 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 12599 -- We are within an instance of some sibling. Retain 12600 -- visibility of parent, for proper subsequent cleanup, and 12601 -- reinstall private declarations as well. 12602 12603 Set_In_Private_Part (P); 12604 Install_Private_Declarations (P); 12605 end if; 12606 12607 -- If the ultimate parent is a top-level unit recorded in 12608 -- Instance_Parent_Unit, then reset its visibility to what it was 12609 -- before instantiation. (It's not clear what the purpose is of 12610 -- testing whether Scope (P) is In_Open_Scopes, but that test was 12611 -- present before the ultimate parent test was added.???) 12612 12613 elsif not In_Open_Scopes (Scope (P)) 12614 or else (P = Instance_Parent_Unit 12615 and then not Parent_Unit_Visible) 12616 then 12617 Set_Is_Immediately_Visible (P, False); 12618 12619 -- If the current scope is itself an instantiation of a generic 12620 -- nested within P, and we are in the private part of body of this 12621 -- instantiation, restore the full views of P, that were removed 12622 -- in End_Package_Scope above. This obscure case can occur when a 12623 -- subunit of a generic contains an instance of a child unit of 12624 -- its generic parent unit. 12625 12626 elsif S = Current_Scope and then Is_Generic_Instance (S) then 12627 declare 12628 Par : constant Entity_Id := 12629 Generic_Parent (Package_Specification (S)); 12630 begin 12631 if Present (Par) 12632 and then P = Scope (Par) 12633 and then (In_Package_Body (S) or else In_Private_Part (S)) 12634 then 12635 Set_In_Private_Part (P); 12636 Install_Private_Declarations (P); 12637 end if; 12638 end; 12639 end if; 12640 end loop; 12641 12642 -- Reset visibility of entities in the enclosing scope 12643 12644 Set_Is_Hidden_Open_Scope (Current_Scope, False); 12645 12646 Hidden := First_Elmt (Hidden_Entities); 12647 while Present (Hidden) loop 12648 Set_Is_Immediately_Visible (Node (Hidden), True); 12649 Next_Elmt (Hidden); 12650 end loop; 12651 12652 else 12653 -- Each body is analyzed separately, and there is no context that 12654 -- needs preserving from one body instance to the next, so remove all 12655 -- parent scopes that have been installed. 12656 12657 while Present (S) loop 12658 End_Package_Scope (S); 12659 Set_Is_Immediately_Visible (S, False); 12660 S := Current_Scope; 12661 exit when S = Standard_Standard; 12662 end loop; 12663 end if; 12664 end Remove_Parent; 12665 12666 ----------------- 12667 -- Restore_Env -- 12668 ----------------- 12669 12670 procedure Restore_Env is 12671 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 12672 12673 begin 12674 if No (Current_Instantiated_Parent.Act_Id) then 12675 -- Restore environment after subprogram inlining 12676 12677 Restore_Private_Views (Empty); 12678 end if; 12679 12680 Current_Instantiated_Parent := Saved.Instantiated_Parent; 12681 Exchanged_Views := Saved.Exchanged_Views; 12682 Hidden_Entities := Saved.Hidden_Entities; 12683 Current_Sem_Unit := Saved.Current_Sem_Unit; 12684 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 12685 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 12686 12687 Restore_Opt_Config_Switches (Saved.Switches); 12688 12689 Instance_Envs.Decrement_Last; 12690 end Restore_Env; 12691 12692 --------------------------- 12693 -- Restore_Private_Views -- 12694 --------------------------- 12695 12696 procedure Restore_Private_Views 12697 (Pack_Id : Entity_Id; 12698 Is_Package : Boolean := True) 12699 is 12700 M : Elmt_Id; 12701 E : Entity_Id; 12702 Typ : Entity_Id; 12703 Dep_Elmt : Elmt_Id; 12704 Dep_Typ : Node_Id; 12705 12706 procedure Restore_Nested_Formal (Formal : Entity_Id); 12707 -- Hide the generic formals of formal packages declared with box which 12708 -- were reachable in the current instantiation. 12709 12710 --------------------------- 12711 -- Restore_Nested_Formal -- 12712 --------------------------- 12713 12714 procedure Restore_Nested_Formal (Formal : Entity_Id) is 12715 Ent : Entity_Id; 12716 12717 begin 12718 if Present (Renamed_Object (Formal)) 12719 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 12720 then 12721 return; 12722 12723 elsif Present (Associated_Formal_Package (Formal)) then 12724 Ent := First_Entity (Formal); 12725 while Present (Ent) loop 12726 exit when Ekind (Ent) = E_Package 12727 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 12728 12729 Set_Is_Hidden (Ent); 12730 Set_Is_Potentially_Use_Visible (Ent, False); 12731 12732 -- If package, then recurse 12733 12734 if Ekind (Ent) = E_Package then 12735 Restore_Nested_Formal (Ent); 12736 end if; 12737 12738 Next_Entity (Ent); 12739 end loop; 12740 end if; 12741 end Restore_Nested_Formal; 12742 12743 -- Start of processing for Restore_Private_Views 12744 12745 begin 12746 M := First_Elmt (Exchanged_Views); 12747 while Present (M) loop 12748 Typ := Node (M); 12749 12750 -- Subtypes of types whose views have been exchanged, and that are 12751 -- defined within the instance, were not on the Private_Dependents 12752 -- list on entry to the instance, so they have to be exchanged 12753 -- explicitly now, in order to remain consistent with the view of the 12754 -- parent type. 12755 12756 if Ekind_In (Typ, E_Private_Type, 12757 E_Limited_Private_Type, 12758 E_Record_Type_With_Private) 12759 then 12760 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 12761 while Present (Dep_Elmt) loop 12762 Dep_Typ := Node (Dep_Elmt); 12763 12764 if Scope (Dep_Typ) = Pack_Id 12765 and then Present (Full_View (Dep_Typ)) 12766 then 12767 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 12768 Exchange_Declarations (Dep_Typ); 12769 end if; 12770 12771 Next_Elmt (Dep_Elmt); 12772 end loop; 12773 end if; 12774 12775 Exchange_Declarations (Node (M)); 12776 Next_Elmt (M); 12777 end loop; 12778 12779 if No (Pack_Id) then 12780 return; 12781 end if; 12782 12783 -- Make the generic formal parameters private, and make the formal types 12784 -- into subtypes of the actuals again. 12785 12786 E := First_Entity (Pack_Id); 12787 while Present (E) loop 12788 Set_Is_Hidden (E, True); 12789 12790 if Is_Type (E) 12791 and then Nkind (Parent (E)) = N_Subtype_Declaration 12792 then 12793 -- If the actual for E is itself a generic actual type from 12794 -- an enclosing instance, E is still a generic actual type 12795 -- outside of the current instance. This matter when resolving 12796 -- an overloaded call that may be ambiguous in the enclosing 12797 -- instance, when two of its actuals coincide. 12798 12799 if Is_Entity_Name (Subtype_Indication (Parent (E))) 12800 and then Is_Generic_Actual_Type 12801 (Entity (Subtype_Indication (Parent (E)))) 12802 then 12803 null; 12804 else 12805 Set_Is_Generic_Actual_Type (E, False); 12806 end if; 12807 12808 -- An unusual case of aliasing: the actual may also be directly 12809 -- visible in the generic, and be private there, while it is fully 12810 -- visible in the context of the instance. The internal subtype 12811 -- is private in the instance but has full visibility like its 12812 -- parent in the enclosing scope. This enforces the invariant that 12813 -- the privacy status of all private dependents of a type coincide 12814 -- with that of the parent type. This can only happen when a 12815 -- generic child unit is instantiated within a sibling. 12816 12817 if Is_Private_Type (E) 12818 and then not Is_Private_Type (Etype (E)) 12819 then 12820 Exchange_Declarations (E); 12821 end if; 12822 12823 elsif Ekind (E) = E_Package then 12824 12825 -- The end of the renaming list is the renaming of the generic 12826 -- package itself. If the instance is a subprogram, all entities 12827 -- in the corresponding package are renamings. If this entity is 12828 -- a formal package, make its own formals private as well. The 12829 -- actual in this case is itself the renaming of an instantiation. 12830 -- If the entity is not a package renaming, it is the entity 12831 -- created to validate formal package actuals: ignore it. 12832 12833 -- If the actual is itself a formal package for the enclosing 12834 -- generic, or the actual for such a formal package, it remains 12835 -- visible on exit from the instance, and therefore nothing needs 12836 -- to be done either, except to keep it accessible. 12837 12838 if Is_Package and then Renamed_Object (E) = Pack_Id then 12839 exit; 12840 12841 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 12842 null; 12843 12844 elsif 12845 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 12846 then 12847 Set_Is_Hidden (E, False); 12848 12849 else 12850 declare 12851 Act_P : constant Entity_Id := Renamed_Object (E); 12852 Id : Entity_Id; 12853 12854 begin 12855 Id := First_Entity (Act_P); 12856 while Present (Id) 12857 and then Id /= First_Private_Entity (Act_P) 12858 loop 12859 exit when Ekind (Id) = E_Package 12860 and then Renamed_Object (Id) = Act_P; 12861 12862 Set_Is_Hidden (Id, True); 12863 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 12864 12865 if Ekind (Id) = E_Package then 12866 Restore_Nested_Formal (Id); 12867 end if; 12868 12869 Next_Entity (Id); 12870 end loop; 12871 end; 12872 end if; 12873 end if; 12874 12875 Next_Entity (E); 12876 end loop; 12877 end Restore_Private_Views; 12878 12879 -------------- 12880 -- Save_Env -- 12881 -------------- 12882 12883 procedure Save_Env 12884 (Gen_Unit : Entity_Id; 12885 Act_Unit : Entity_Id) 12886 is 12887 begin 12888 Init_Env; 12889 Set_Instance_Env (Gen_Unit, Act_Unit); 12890 end Save_Env; 12891 12892 ---------------------------- 12893 -- Save_Global_References -- 12894 ---------------------------- 12895 12896 procedure Save_Global_References (N : Node_Id) is 12897 Gen_Scope : Entity_Id; 12898 E : Entity_Id; 12899 N2 : Node_Id; 12900 12901 function Is_Global (E : Entity_Id) return Boolean; 12902 -- Check whether entity is defined outside of generic unit. Examine the 12903 -- scope of an entity, and the scope of the scope, etc, until we find 12904 -- either Standard, in which case the entity is global, or the generic 12905 -- unit itself, which indicates that the entity is local. If the entity 12906 -- is the generic unit itself, as in the case of a recursive call, or 12907 -- the enclosing generic unit, if different from the current scope, then 12908 -- it is local as well, because it will be replaced at the point of 12909 -- instantiation. On the other hand, if it is a reference to a child 12910 -- unit of a common ancestor, which appears in an instantiation, it is 12911 -- global because it is used to denote a specific compilation unit at 12912 -- the time the instantiations will be analyzed. 12913 12914 procedure Reset_Entity (N : Node_Id); 12915 -- Save semantic information on global entity so that it is not resolved 12916 -- again at instantiation time. 12917 12918 procedure Save_Entity_Descendants (N : Node_Id); 12919 -- Apply Save_Global_References to the two syntactic descendants of 12920 -- non-terminal nodes that carry an Associated_Node and are processed 12921 -- through Reset_Entity. Once the global entity (if any) has been 12922 -- captured together with its type, only two syntactic descendants need 12923 -- to be traversed to complete the processing of the tree rooted at N. 12924 -- This applies to Selected_Components, Expanded_Names, and to Operator 12925 -- nodes. N can also be a character literal, identifier, or operator 12926 -- symbol node, but the call has no effect in these cases. 12927 12928 procedure Save_Global_Defaults (N1, N2 : Node_Id); 12929 -- Default actuals in nested instances must be handled specially 12930 -- because there is no link to them from the original tree. When an 12931 -- actual subprogram is given by a default, we add an explicit generic 12932 -- association for it in the instantiation node. When we save the 12933 -- global references on the name of the instance, we recover the list 12934 -- of generic associations, and add an explicit one to the original 12935 -- generic tree, through which a global actual can be preserved. 12936 -- Similarly, if a child unit is instantiated within a sibling, in the 12937 -- context of the parent, we must preserve the identifier of the parent 12938 -- so that it can be properly resolved in a subsequent instantiation. 12939 12940 procedure Save_Global_Descendant (D : Union_Id); 12941 -- Apply Save_Global_References recursively to the descendents of the 12942 -- current node. 12943 12944 procedure Save_References (N : Node_Id); 12945 -- This is the recursive procedure that does the work, once the 12946 -- enclosing generic scope has been established. 12947 12948 --------------- 12949 -- Is_Global -- 12950 --------------- 12951 12952 function Is_Global (E : Entity_Id) return Boolean is 12953 Se : Entity_Id; 12954 12955 function Is_Instance_Node (Decl : Node_Id) return Boolean; 12956 -- Determine whether the parent node of a reference to a child unit 12957 -- denotes an instantiation or a formal package, in which case the 12958 -- reference to the child unit is global, even if it appears within 12959 -- the current scope (e.g. when the instance appears within the body 12960 -- of an ancestor). 12961 12962 ---------------------- 12963 -- Is_Instance_Node -- 12964 ---------------------- 12965 12966 function Is_Instance_Node (Decl : Node_Id) return Boolean is 12967 begin 12968 return Nkind (Decl) in N_Generic_Instantiation 12969 or else 12970 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 12971 end Is_Instance_Node; 12972 12973 -- Start of processing for Is_Global 12974 12975 begin 12976 if E = Gen_Scope then 12977 return False; 12978 12979 elsif E = Standard_Standard then 12980 return True; 12981 12982 elsif Is_Child_Unit (E) 12983 and then (Is_Instance_Node (Parent (N2)) 12984 or else (Nkind (Parent (N2)) = N_Expanded_Name 12985 and then N2 = Selector_Name (Parent (N2)) 12986 and then 12987 Is_Instance_Node (Parent (Parent (N2))))) 12988 then 12989 return True; 12990 12991 else 12992 Se := Scope (E); 12993 while Se /= Gen_Scope loop 12994 if Se = Standard_Standard then 12995 return True; 12996 else 12997 Se := Scope (Se); 12998 end if; 12999 end loop; 13000 13001 return False; 13002 end if; 13003 end Is_Global; 13004 13005 ------------------ 13006 -- Reset_Entity -- 13007 ------------------ 13008 13009 procedure Reset_Entity (N : Node_Id) is 13010 13011 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 13012 -- If the type of N2 is global to the generic unit, save the type in 13013 -- the generic node. Just as we perform name capture for explicit 13014 -- references within the generic, we must capture the global types 13015 -- of local entities because they may participate in resolution in 13016 -- the instance. 13017 13018 function Top_Ancestor (E : Entity_Id) return Entity_Id; 13019 -- Find the ultimate ancestor of the current unit. If it is not a 13020 -- generic unit, then the name of the current unit in the prefix of 13021 -- an expanded name must be replaced with its generic homonym to 13022 -- ensure that it will be properly resolved in an instance. 13023 13024 --------------------- 13025 -- Set_Global_Type -- 13026 --------------------- 13027 13028 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 13029 Typ : constant Entity_Id := Etype (N2); 13030 13031 begin 13032 Set_Etype (N, Typ); 13033 13034 if Entity (N) /= N2 13035 and then Has_Private_View (Entity (N)) 13036 then 13037 -- If the entity of N is not the associated node, this is a 13038 -- nested generic and it has an associated node as well, whose 13039 -- type is already the full view (see below). Indicate that the 13040 -- original node has a private view. 13041 13042 Set_Has_Private_View (N); 13043 end if; 13044 13045 -- If not a private type, nothing else to do 13046 13047 if not Is_Private_Type (Typ) then 13048 if Is_Array_Type (Typ) 13049 and then Is_Private_Type (Component_Type (Typ)) 13050 then 13051 Set_Has_Private_View (N); 13052 end if; 13053 13054 -- If it is a derivation of a private type in a context where no 13055 -- full view is needed, nothing to do either. 13056 13057 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 13058 null; 13059 13060 -- Otherwise mark the type for flipping and use the full view when 13061 -- available. 13062 13063 else 13064 Set_Has_Private_View (N); 13065 13066 if Present (Full_View (Typ)) then 13067 Set_Etype (N2, Full_View (Typ)); 13068 end if; 13069 end if; 13070 end Set_Global_Type; 13071 13072 ------------------ 13073 -- Top_Ancestor -- 13074 ------------------ 13075 13076 function Top_Ancestor (E : Entity_Id) return Entity_Id is 13077 Par : Entity_Id; 13078 13079 begin 13080 Par := E; 13081 while Is_Child_Unit (Par) loop 13082 Par := Scope (Par); 13083 end loop; 13084 13085 return Par; 13086 end Top_Ancestor; 13087 13088 -- Start of processing for Reset_Entity 13089 13090 begin 13091 N2 := Get_Associated_Node (N); 13092 E := Entity (N2); 13093 13094 if Present (E) then 13095 13096 -- If the node is an entry call to an entry in an enclosing task, 13097 -- it is rewritten as a selected component. No global entity to 13098 -- preserve in this case, since the expansion will be redone in 13099 -- the instance. 13100 13101 if not Nkind_In (E, N_Defining_Identifier, 13102 N_Defining_Character_Literal, 13103 N_Defining_Operator_Symbol) 13104 then 13105 Set_Associated_Node (N, Empty); 13106 Set_Etype (N, Empty); 13107 return; 13108 end if; 13109 13110 -- If the entity is an itype created as a subtype of an access 13111 -- type with a null exclusion restore source entity for proper 13112 -- visibility. The itype will be created anew in the instance. 13113 13114 if Is_Itype (E) 13115 and then Ekind (E) = E_Access_Subtype 13116 and then Is_Entity_Name (N) 13117 and then Chars (Etype (E)) = Chars (N) 13118 then 13119 E := Etype (E); 13120 Set_Entity (N2, E); 13121 Set_Etype (N2, E); 13122 end if; 13123 13124 if Is_Global (E) then 13125 13126 -- If the entity is a package renaming that is the prefix of 13127 -- an expanded name, it has been rewritten as the renamed 13128 -- package, which is necessary semantically but complicates 13129 -- ASIS tree traversal, so we recover the original entity to 13130 -- expose the renaming. Take into account that the context may 13131 -- be a nested generic, that the original node may itself have 13132 -- an associated node that had better be an entity, and that 13133 -- the current node is still a selected component. 13134 13135 if Ekind (E) = E_Package 13136 and then Nkind (N) = N_Selected_Component 13137 and then Nkind (Parent (N)) = N_Expanded_Name 13138 and then Present (Original_Node (N2)) 13139 and then Is_Entity_Name (Original_Node (N2)) 13140 and then Present (Entity (Original_Node (N2))) 13141 then 13142 if Is_Global (Entity (Original_Node (N2))) then 13143 N2 := Original_Node (N2); 13144 Set_Associated_Node (N, N2); 13145 Set_Global_Type (N, N2); 13146 13147 else 13148 -- Renaming is local, and will be resolved in instance 13149 13150 Set_Associated_Node (N, Empty); 13151 Set_Etype (N, Empty); 13152 end if; 13153 13154 else 13155 Set_Global_Type (N, N2); 13156 end if; 13157 13158 elsif Nkind (N) = N_Op_Concat 13159 and then Is_Generic_Type (Etype (N2)) 13160 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 13161 or else 13162 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 13163 and then Is_Intrinsic_Subprogram (E) 13164 then 13165 null; 13166 13167 else 13168 -- Entity is local. Mark generic node as unresolved. 13169 -- Note that now it does not have an entity. 13170 13171 Set_Associated_Node (N, Empty); 13172 Set_Etype (N, Empty); 13173 end if; 13174 13175 if Nkind (Parent (N)) in N_Generic_Instantiation 13176 and then N = Name (Parent (N)) 13177 then 13178 Save_Global_Defaults (Parent (N), Parent (N2)); 13179 end if; 13180 13181 elsif Nkind (Parent (N)) = N_Selected_Component 13182 and then Nkind (Parent (N2)) = N_Expanded_Name 13183 then 13184 if Is_Global (Entity (Parent (N2))) then 13185 Change_Selected_Component_To_Expanded_Name (Parent (N)); 13186 Set_Associated_Node (Parent (N), Parent (N2)); 13187 Set_Global_Type (Parent (N), Parent (N2)); 13188 Save_Entity_Descendants (N); 13189 13190 -- If this is a reference to the current generic entity, replace 13191 -- by the name of the generic homonym of the current package. This 13192 -- is because in an instantiation Par.P.Q will not resolve to the 13193 -- name of the instance, whose enclosing scope is not necessarily 13194 -- Par. We use the generic homonym rather that the name of the 13195 -- generic itself because it may be hidden by a local declaration. 13196 13197 elsif In_Open_Scopes (Entity (Parent (N2))) 13198 and then not 13199 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 13200 then 13201 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 13202 Rewrite (Parent (N), 13203 Make_Identifier (Sloc (N), 13204 Chars => 13205 Chars (Generic_Homonym (Entity (Parent (N2)))))); 13206 else 13207 Rewrite (Parent (N), 13208 Make_Identifier (Sloc (N), 13209 Chars => Chars (Selector_Name (Parent (N2))))); 13210 end if; 13211 end if; 13212 13213 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 13214 and then Parent (N) = Name (Parent (Parent (N))) 13215 then 13216 Save_Global_Defaults 13217 (Parent (Parent (N)), Parent (Parent ((N2)))); 13218 end if; 13219 13220 -- A selected component may denote a static constant that has been 13221 -- folded. If the static constant is global to the generic, capture 13222 -- its value. Otherwise the folding will happen in any instantiation. 13223 13224 elsif Nkind (Parent (N)) = N_Selected_Component 13225 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 13226 then 13227 if Present (Entity (Original_Node (Parent (N2)))) 13228 and then Is_Global (Entity (Original_Node (Parent (N2)))) 13229 then 13230 Rewrite (Parent (N), New_Copy (Parent (N2))); 13231 Set_Analyzed (Parent (N), False); 13232 13233 else 13234 null; 13235 end if; 13236 13237 -- A selected component may be transformed into a parameterless 13238 -- function call. If the called entity is global, rewrite the node 13239 -- appropriately, i.e. as an extended name for the global entity. 13240 13241 elsif Nkind (Parent (N)) = N_Selected_Component 13242 and then Nkind (Parent (N2)) = N_Function_Call 13243 and then N = Selector_Name (Parent (N)) 13244 then 13245 if No (Parameter_Associations (Parent (N2))) then 13246 if Is_Global (Entity (Name (Parent (N2)))) then 13247 Change_Selected_Component_To_Expanded_Name (Parent (N)); 13248 Set_Associated_Node (Parent (N), Name (Parent (N2))); 13249 Set_Global_Type (Parent (N), Name (Parent (N2))); 13250 Save_Entity_Descendants (N); 13251 13252 else 13253 Set_Is_Prefixed_Call (Parent (N)); 13254 Set_Associated_Node (N, Empty); 13255 Set_Etype (N, Empty); 13256 end if; 13257 13258 -- In Ada 2005, X.F may be a call to a primitive operation, 13259 -- rewritten as F (X). This rewriting will be done again in an 13260 -- instance, so keep the original node. Global entities will be 13261 -- captured as for other constructs. Indicate that this must 13262 -- resolve as a call, to prevent accidental overloading in the 13263 -- instance, if both a component and a primitive operation appear 13264 -- as candidates. 13265 13266 else 13267 Set_Is_Prefixed_Call (Parent (N)); 13268 end if; 13269 13270 -- Entity is local. Reset in generic unit, so that node is resolved 13271 -- anew at the point of instantiation. 13272 13273 else 13274 Set_Associated_Node (N, Empty); 13275 Set_Etype (N, Empty); 13276 end if; 13277 end Reset_Entity; 13278 13279 ----------------------------- 13280 -- Save_Entity_Descendants -- 13281 ----------------------------- 13282 13283 procedure Save_Entity_Descendants (N : Node_Id) is 13284 begin 13285 case Nkind (N) is 13286 when N_Binary_Op => 13287 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 13288 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 13289 13290 when N_Unary_Op => 13291 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 13292 13293 when N_Expanded_Name | N_Selected_Component => 13294 Save_Global_Descendant (Union_Id (Prefix (N))); 13295 Save_Global_Descendant (Union_Id (Selector_Name (N))); 13296 13297 when N_Identifier | N_Character_Literal | N_Operator_Symbol => 13298 null; 13299 13300 when others => 13301 raise Program_Error; 13302 end case; 13303 end Save_Entity_Descendants; 13304 13305 -------------------------- 13306 -- Save_Global_Defaults -- 13307 -------------------------- 13308 13309 procedure Save_Global_Defaults (N1, N2 : Node_Id) is 13310 Loc : constant Source_Ptr := Sloc (N1); 13311 Assoc2 : constant List_Id := Generic_Associations (N2); 13312 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 13313 Assoc1 : List_Id; 13314 Act1 : Node_Id; 13315 Act2 : Node_Id; 13316 Def : Node_Id; 13317 Ndec : Node_Id; 13318 Subp : Entity_Id; 13319 Actual : Entity_Id; 13320 13321 begin 13322 Assoc1 := Generic_Associations (N1); 13323 13324 if Present (Assoc1) then 13325 Act1 := First (Assoc1); 13326 else 13327 Act1 := Empty; 13328 Set_Generic_Associations (N1, New_List); 13329 Assoc1 := Generic_Associations (N1); 13330 end if; 13331 13332 if Present (Assoc2) then 13333 Act2 := First (Assoc2); 13334 else 13335 return; 13336 end if; 13337 13338 while Present (Act1) and then Present (Act2) loop 13339 Next (Act1); 13340 Next (Act2); 13341 end loop; 13342 13343 -- Find the associations added for default subprograms 13344 13345 if Present (Act2) then 13346 while Nkind (Act2) /= N_Generic_Association 13347 or else No (Entity (Selector_Name (Act2))) 13348 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 13349 loop 13350 Next (Act2); 13351 end loop; 13352 13353 -- Add a similar association if the default is global. The 13354 -- renaming declaration for the actual has been analyzed, and 13355 -- its alias is the program it renames. Link the actual in the 13356 -- original generic tree with the node in the analyzed tree. 13357 13358 while Present (Act2) loop 13359 Subp := Entity (Selector_Name (Act2)); 13360 Def := Explicit_Generic_Actual_Parameter (Act2); 13361 13362 -- Following test is defence against rubbish errors 13363 13364 if No (Alias (Subp)) then 13365 return; 13366 end if; 13367 13368 -- Retrieve the resolved actual from the renaming declaration 13369 -- created for the instantiated formal. 13370 13371 Actual := Entity (Name (Parent (Parent (Subp)))); 13372 Set_Entity (Def, Actual); 13373 Set_Etype (Def, Etype (Actual)); 13374 13375 if Is_Global (Actual) then 13376 Ndec := 13377 Make_Generic_Association (Loc, 13378 Selector_Name => New_Occurrence_Of (Subp, Loc), 13379 Explicit_Generic_Actual_Parameter => 13380 New_Occurrence_Of (Actual, Loc)); 13381 13382 Set_Associated_Node 13383 (Explicit_Generic_Actual_Parameter (Ndec), Def); 13384 13385 Append (Ndec, Assoc1); 13386 13387 -- If there are other defaults, add a dummy association in case 13388 -- there are other defaulted formals with the same name. 13389 13390 elsif Present (Next (Act2)) then 13391 Ndec := 13392 Make_Generic_Association (Loc, 13393 Selector_Name => New_Occurrence_Of (Subp, Loc), 13394 Explicit_Generic_Actual_Parameter => Empty); 13395 13396 Append (Ndec, Assoc1); 13397 end if; 13398 13399 Next (Act2); 13400 end loop; 13401 end if; 13402 13403 if Nkind (Name (N1)) = N_Identifier 13404 and then Is_Child_Unit (Gen_Id) 13405 and then Is_Global (Gen_Id) 13406 and then Is_Generic_Unit (Scope (Gen_Id)) 13407 and then In_Open_Scopes (Scope (Gen_Id)) 13408 then 13409 -- This is an instantiation of a child unit within a sibling, so 13410 -- that the generic parent is in scope. An eventual instance must 13411 -- occur within the scope of an instance of the parent. Make name 13412 -- in instance into an expanded name, to preserve the identifier 13413 -- of the parent, so it can be resolved subsequently. 13414 13415 Rewrite (Name (N2), 13416 Make_Expanded_Name (Loc, 13417 Chars => Chars (Gen_Id), 13418 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 13419 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 13420 Set_Entity (Name (N2), Gen_Id); 13421 13422 Rewrite (Name (N1), 13423 Make_Expanded_Name (Loc, 13424 Chars => Chars (Gen_Id), 13425 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 13426 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 13427 13428 Set_Associated_Node (Name (N1), Name (N2)); 13429 Set_Associated_Node (Prefix (Name (N1)), Empty); 13430 Set_Associated_Node 13431 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 13432 Set_Etype (Name (N1), Etype (Gen_Id)); 13433 end if; 13434 13435 end Save_Global_Defaults; 13436 13437 ---------------------------- 13438 -- Save_Global_Descendant -- 13439 ---------------------------- 13440 13441 procedure Save_Global_Descendant (D : Union_Id) is 13442 N1 : Node_Id; 13443 13444 begin 13445 if D in Node_Range then 13446 if D = Union_Id (Empty) then 13447 null; 13448 13449 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 13450 Save_References (Node_Id (D)); 13451 end if; 13452 13453 elsif D in List_Range then 13454 if D = Union_Id (No_List) 13455 or else Is_Empty_List (List_Id (D)) 13456 then 13457 null; 13458 13459 else 13460 N1 := First (List_Id (D)); 13461 while Present (N1) loop 13462 Save_References (N1); 13463 Next (N1); 13464 end loop; 13465 end if; 13466 13467 -- Element list or other non-node field, nothing to do 13468 13469 else 13470 null; 13471 end if; 13472 end Save_Global_Descendant; 13473 13474 --------------------- 13475 -- Save_References -- 13476 --------------------- 13477 13478 -- This is the recursive procedure that does the work once the enclosing 13479 -- generic scope has been established. We have to treat specially a 13480 -- number of node rewritings that are required by semantic processing 13481 -- and which change the kind of nodes in the generic copy: typically 13482 -- constant-folding, replacing an operator node by a string literal, or 13483 -- a selected component by an expanded name. In each of those cases, the 13484 -- transformation is propagated to the generic unit. 13485 13486 procedure Save_References (N : Node_Id) is 13487 Loc : constant Source_Ptr := Sloc (N); 13488 13489 begin 13490 if N = Empty then 13491 null; 13492 13493 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 13494 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13495 Reset_Entity (N); 13496 13497 elsif Nkind (N) = N_Operator_Symbol 13498 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 13499 then 13500 Change_Operator_Symbol_To_String_Literal (N); 13501 end if; 13502 13503 elsif Nkind (N) in N_Op then 13504 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13505 if Nkind (N) = N_Op_Concat then 13506 Set_Is_Component_Left_Opnd (N, 13507 Is_Component_Left_Opnd (Get_Associated_Node (N))); 13508 13509 Set_Is_Component_Right_Opnd (N, 13510 Is_Component_Right_Opnd (Get_Associated_Node (N))); 13511 end if; 13512 13513 Reset_Entity (N); 13514 13515 else 13516 -- Node may be transformed into call to a user-defined operator 13517 13518 N2 := Get_Associated_Node (N); 13519 13520 if Nkind (N2) = N_Function_Call then 13521 E := Entity (Name (N2)); 13522 13523 if Present (E) 13524 and then Is_Global (E) 13525 then 13526 Set_Etype (N, Etype (N2)); 13527 else 13528 Set_Associated_Node (N, Empty); 13529 Set_Etype (N, Empty); 13530 end if; 13531 13532 elsif Nkind_In (N2, N_Integer_Literal, 13533 N_Real_Literal, 13534 N_String_Literal) 13535 then 13536 if Present (Original_Node (N2)) 13537 and then Nkind (Original_Node (N2)) = Nkind (N) 13538 then 13539 13540 -- Operation was constant-folded. Whenever possible, 13541 -- recover semantic information from unfolded node, 13542 -- for ASIS use. 13543 13544 Set_Associated_Node (N, Original_Node (N2)); 13545 13546 if Nkind (N) = N_Op_Concat then 13547 Set_Is_Component_Left_Opnd (N, 13548 Is_Component_Left_Opnd (Get_Associated_Node (N))); 13549 Set_Is_Component_Right_Opnd (N, 13550 Is_Component_Right_Opnd (Get_Associated_Node (N))); 13551 end if; 13552 13553 Reset_Entity (N); 13554 13555 else 13556 -- If original node is already modified, propagate 13557 -- constant-folding to template. 13558 13559 Rewrite (N, New_Copy (N2)); 13560 Set_Analyzed (N, False); 13561 end if; 13562 13563 elsif Nkind (N2) = N_Identifier 13564 and then Ekind (Entity (N2)) = E_Enumeration_Literal 13565 then 13566 -- Same if call was folded into a literal, but in this case 13567 -- retain the entity to avoid spurious ambiguities if it is 13568 -- overloaded at the point of instantiation or inlining. 13569 13570 Rewrite (N, New_Copy (N2)); 13571 Set_Analyzed (N, False); 13572 end if; 13573 end if; 13574 13575 -- Complete operands check if node has not been constant-folded 13576 13577 if Nkind (N) in N_Op then 13578 Save_Entity_Descendants (N); 13579 end if; 13580 13581 elsif Nkind (N) = N_Identifier then 13582 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 13583 13584 -- If this is a discriminant reference, always save it. It is 13585 -- used in the instance to find the corresponding discriminant 13586 -- positionally rather than by name. 13587 13588 Set_Original_Discriminant 13589 (N, Original_Discriminant (Get_Associated_Node (N))); 13590 Reset_Entity (N); 13591 13592 else 13593 N2 := Get_Associated_Node (N); 13594 13595 if Nkind (N2) = N_Function_Call then 13596 E := Entity (Name (N2)); 13597 13598 -- Name resolves to a call to parameterless function. If 13599 -- original entity is global, mark node as resolved. 13600 13601 if Present (E) 13602 and then Is_Global (E) 13603 then 13604 Set_Etype (N, Etype (N2)); 13605 else 13606 Set_Associated_Node (N, Empty); 13607 Set_Etype (N, Empty); 13608 end if; 13609 13610 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 13611 and then Is_Entity_Name (Original_Node (N2)) 13612 then 13613 -- Name resolves to named number that is constant-folded, 13614 -- We must preserve the original name for ASIS use, and 13615 -- undo the constant-folding, which will be repeated in 13616 -- each instance. 13617 13618 Set_Associated_Node (N, Original_Node (N2)); 13619 Reset_Entity (N); 13620 13621 elsif Nkind (N2) = N_String_Literal then 13622 13623 -- Name resolves to string literal. Perform the same 13624 -- replacement in generic. 13625 13626 Rewrite (N, New_Copy (N2)); 13627 13628 elsif Nkind (N2) = N_Explicit_Dereference then 13629 13630 -- An identifier is rewritten as a dereference if it is the 13631 -- prefix in an implicit dereference (call or attribute). 13632 -- The analysis of an instantiation will expand the node 13633 -- again, so we preserve the original tree but link it to 13634 -- the resolved entity in case it is global. 13635 13636 if Is_Entity_Name (Prefix (N2)) 13637 and then Present (Entity (Prefix (N2))) 13638 and then Is_Global (Entity (Prefix (N2))) 13639 then 13640 Set_Associated_Node (N, Prefix (N2)); 13641 13642 elsif Nkind (Prefix (N2)) = N_Function_Call 13643 and then Is_Global (Entity (Name (Prefix (N2)))) 13644 then 13645 Rewrite (N, 13646 Make_Explicit_Dereference (Loc, 13647 Prefix => Make_Function_Call (Loc, 13648 Name => 13649 New_Occurrence_Of (Entity (Name (Prefix (N2))), 13650 Loc)))); 13651 13652 else 13653 Set_Associated_Node (N, Empty); 13654 Set_Etype (N, Empty); 13655 end if; 13656 13657 -- The subtype mark of a nominally unconstrained object is 13658 -- rewritten as a subtype indication using the bounds of the 13659 -- expression. Recover the original subtype mark. 13660 13661 elsif Nkind (N2) = N_Subtype_Indication 13662 and then Is_Entity_Name (Original_Node (N2)) 13663 then 13664 Set_Associated_Node (N, Original_Node (N2)); 13665 Reset_Entity (N); 13666 13667 else 13668 null; 13669 end if; 13670 end if; 13671 13672 elsif Nkind (N) in N_Entity then 13673 null; 13674 13675 else 13676 declare 13677 Qual : Node_Id := Empty; 13678 Typ : Entity_Id := Empty; 13679 Nam : Node_Id; 13680 13681 use Atree.Unchecked_Access; 13682 -- This code section is part of implementing an untyped tree 13683 -- traversal, so it needs direct access to node fields. 13684 13685 begin 13686 if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 13687 N2 := Get_Associated_Node (N); 13688 13689 if No (N2) then 13690 Typ := Empty; 13691 else 13692 Typ := Etype (N2); 13693 13694 -- In an instance within a generic, use the name of the 13695 -- actual and not the original generic parameter. If the 13696 -- actual is global in the current generic it must be 13697 -- preserved for its instantiation. 13698 13699 if Nkind (Parent (Typ)) = N_Subtype_Declaration 13700 and then 13701 Present (Generic_Parent_Type (Parent (Typ))) 13702 then 13703 Typ := Base_Type (Typ); 13704 Set_Etype (N2, Typ); 13705 end if; 13706 end if; 13707 13708 if No (N2) 13709 or else No (Typ) 13710 or else not Is_Global (Typ) 13711 then 13712 Set_Associated_Node (N, Empty); 13713 13714 -- If the aggregate is an actual in a call, it has been 13715 -- resolved in the current context, to some local type. 13716 -- The enclosing call may have been disambiguated by the 13717 -- aggregate, and this disambiguation might fail at 13718 -- instantiation time because the type to which the 13719 -- aggregate did resolve is not preserved. In order to 13720 -- preserve some of this information, we wrap the 13721 -- aggregate in a qualified expression, using the id of 13722 -- its type. For further disambiguation we qualify the 13723 -- type name with its scope (if visible) because both 13724 -- id's will have corresponding entities in an instance. 13725 -- This resolves most of the problems with missing type 13726 -- information on aggregates in instances. 13727 13728 if Nkind (N2) = Nkind (N) 13729 and then Nkind (Parent (N2)) in N_Subprogram_Call 13730 and then Comes_From_Source (Typ) 13731 then 13732 if Is_Immediately_Visible (Scope (Typ)) then 13733 Nam := Make_Selected_Component (Loc, 13734 Prefix => 13735 Make_Identifier (Loc, Chars (Scope (Typ))), 13736 Selector_Name => 13737 Make_Identifier (Loc, Chars (Typ))); 13738 else 13739 Nam := Make_Identifier (Loc, Chars (Typ)); 13740 end if; 13741 13742 Qual := 13743 Make_Qualified_Expression (Loc, 13744 Subtype_Mark => Nam, 13745 Expression => Relocate_Node (N)); 13746 end if; 13747 end if; 13748 13749 Save_Global_Descendant (Field1 (N)); 13750 Save_Global_Descendant (Field2 (N)); 13751 Save_Global_Descendant (Field3 (N)); 13752 Save_Global_Descendant (Field5 (N)); 13753 13754 if Present (Qual) then 13755 Rewrite (N, Qual); 13756 end if; 13757 13758 -- All other cases than aggregates 13759 13760 else 13761 Save_Global_Descendant (Field1 (N)); 13762 Save_Global_Descendant (Field2 (N)); 13763 Save_Global_Descendant (Field3 (N)); 13764 Save_Global_Descendant (Field4 (N)); 13765 Save_Global_Descendant (Field5 (N)); 13766 end if; 13767 end; 13768 end if; 13769 13770 -- If a node has aspects, references within their expressions must 13771 -- be saved separately, given they are not directly in the tree. 13772 13773 if Has_Aspects (N) then 13774 declare 13775 Aspect : Node_Id; 13776 13777 begin 13778 Aspect := First (Aspect_Specifications (N)); 13779 while Present (Aspect) loop 13780 if Present (Expression (Aspect)) then 13781 Save_Global_References (Expression (Aspect)); 13782 end if; 13783 13784 Next (Aspect); 13785 end loop; 13786 end; 13787 end if; 13788 end Save_References; 13789 13790 -- Start of processing for Save_Global_References 13791 13792 begin 13793 Gen_Scope := Current_Scope; 13794 13795 -- If the generic unit is a child unit, references to entities in the 13796 -- parent are treated as local, because they will be resolved anew in 13797 -- the context of the instance of the parent. 13798 13799 while Is_Child_Unit (Gen_Scope) 13800 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 13801 loop 13802 Gen_Scope := Scope (Gen_Scope); 13803 end loop; 13804 13805 Save_References (N); 13806 end Save_Global_References; 13807 13808 -------------------------------------- 13809 -- Set_Copied_Sloc_For_Inlined_Body -- 13810 -------------------------------------- 13811 13812 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 13813 begin 13814 Create_Instantiation_Source (N, E, True, S_Adjustment); 13815 end Set_Copied_Sloc_For_Inlined_Body; 13816 13817 --------------------- 13818 -- Set_Instance_Of -- 13819 --------------------- 13820 13821 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 13822 begin 13823 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 13824 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 13825 Generic_Renamings.Increment_Last; 13826 end Set_Instance_Of; 13827 13828 -------------------- 13829 -- Set_Next_Assoc -- 13830 -------------------- 13831 13832 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 13833 begin 13834 Generic_Renamings.Table (E).Next_In_HTable := Next; 13835 end Set_Next_Assoc; 13836 13837 ------------------- 13838 -- Start_Generic -- 13839 ------------------- 13840 13841 procedure Start_Generic is 13842 begin 13843 -- ??? More things could be factored out in this routine. 13844 -- Should probably be done at a later stage. 13845 13846 Generic_Flags.Append (Inside_A_Generic); 13847 Inside_A_Generic := True; 13848 13849 Expander_Mode_Save_And_Set (False); 13850 end Start_Generic; 13851 13852 ---------------------- 13853 -- Set_Instance_Env -- 13854 ---------------------- 13855 13856 procedure Set_Instance_Env 13857 (Gen_Unit : Entity_Id; 13858 Act_Unit : Entity_Id) 13859 is 13860 Assertion_Status : constant Boolean := Assertions_Enabled; 13861 Save_SPARK_Mode : constant SPARK_Mode_Type := SPARK_Mode; 13862 Save_SPARK_Mode_Pragma : constant Node_Id := SPARK_Mode_Pragma; 13863 13864 begin 13865 -- Regardless of the current mode, predefined units are analyzed in the 13866 -- most current Ada mode, and earlier version Ada checks do not apply 13867 -- to predefined units. Nothing needs to be done for non-internal units. 13868 -- These are always analyzed in the current mode. 13869 13870 if Is_Internal_File_Name 13871 (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), 13872 Renamings_Included => True) 13873 then 13874 Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); 13875 13876 -- In Ada2012 we may want to enable assertions in an instance of a 13877 -- predefined unit, in which case we need to preserve the current 13878 -- setting for the Assertions_Enabled flag. This will become more 13879 -- critical when pre/postconditions are added to predefined units, 13880 -- as is already the case for some numeric libraries. 13881 13882 if Ada_Version >= Ada_2012 then 13883 Assertions_Enabled := Assertion_Status; 13884 end if; 13885 13886 -- SPARK_Mode for an instance is the one applicable at the point of 13887 -- instantiation. 13888 13889 SPARK_Mode := Save_SPARK_Mode; 13890 SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma; 13891 end if; 13892 13893 Current_Instantiated_Parent := 13894 (Gen_Id => Gen_Unit, 13895 Act_Id => Act_Unit, 13896 Next_In_HTable => Assoc_Null); 13897 end Set_Instance_Env; 13898 13899 ----------------- 13900 -- Switch_View -- 13901 ----------------- 13902 13903 procedure Switch_View (T : Entity_Id) is 13904 BT : constant Entity_Id := Base_Type (T); 13905 Priv_Elmt : Elmt_Id := No_Elmt; 13906 Priv_Sub : Entity_Id; 13907 13908 begin 13909 -- T may be private but its base type may have been exchanged through 13910 -- some other occurrence, in which case there is nothing to switch 13911 -- besides T itself. Note that a private dependent subtype of a private 13912 -- type might not have been switched even if the base type has been, 13913 -- because of the last branch of Check_Private_View (see comment there). 13914 13915 if not Is_Private_Type (BT) then 13916 Prepend_Elmt (Full_View (T), Exchanged_Views); 13917 Exchange_Declarations (T); 13918 return; 13919 end if; 13920 13921 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 13922 13923 if Present (Full_View (BT)) then 13924 Prepend_Elmt (Full_View (BT), Exchanged_Views); 13925 Exchange_Declarations (BT); 13926 end if; 13927 13928 while Present (Priv_Elmt) loop 13929 Priv_Sub := (Node (Priv_Elmt)); 13930 13931 -- We avoid flipping the subtype if the Etype of its full view is 13932 -- private because this would result in a malformed subtype. This 13933 -- occurs when the Etype of the subtype full view is the full view of 13934 -- the base type (and since the base types were just switched, the 13935 -- subtype is pointing to the wrong view). This is currently the case 13936 -- for tagged record types, access types (maybe more?) and needs to 13937 -- be resolved. ??? 13938 13939 if Present (Full_View (Priv_Sub)) 13940 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 13941 then 13942 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 13943 Exchange_Declarations (Priv_Sub); 13944 end if; 13945 13946 Next_Elmt (Priv_Elmt); 13947 end loop; 13948 end Switch_View; 13949 13950 ----------------- 13951 -- True_Parent -- 13952 ----------------- 13953 13954 function True_Parent (N : Node_Id) return Node_Id is 13955 begin 13956 if Nkind (Parent (N)) = N_Subunit then 13957 return Parent (Corresponding_Stub (Parent (N))); 13958 else 13959 return Parent (N); 13960 end if; 13961 end True_Parent; 13962 13963 ----------------------------- 13964 -- Valid_Default_Attribute -- 13965 ----------------------------- 13966 13967 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 13968 Attr_Id : constant Attribute_Id := 13969 Get_Attribute_Id (Attribute_Name (Def)); 13970 T : constant Entity_Id := Entity (Prefix (Def)); 13971 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 13972 F : Entity_Id; 13973 Num_F : Int; 13974 OK : Boolean; 13975 13976 begin 13977 if No (T) 13978 or else T = Any_Id 13979 then 13980 return; 13981 end if; 13982 13983 Num_F := 0; 13984 F := First_Formal (Nam); 13985 while Present (F) loop 13986 Num_F := Num_F + 1; 13987 Next_Formal (F); 13988 end loop; 13989 13990 case Attr_Id is 13991 when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign | 13992 Attribute_Floor | Attribute_Fraction | Attribute_Machine | 13993 Attribute_Model | Attribute_Remainder | Attribute_Rounding | 13994 Attribute_Unbiased_Rounding => 13995 OK := Is_Fun 13996 and then Num_F = 1 13997 and then Is_Floating_Point_Type (T); 13998 13999 when Attribute_Image | Attribute_Pred | Attribute_Succ | 14000 Attribute_Value | Attribute_Wide_Image | 14001 Attribute_Wide_Value => 14002 OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T)); 14003 14004 when Attribute_Max | Attribute_Min => 14005 OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T)); 14006 14007 when Attribute_Input => 14008 OK := (Is_Fun and then Num_F = 1); 14009 14010 when Attribute_Output | Attribute_Read | Attribute_Write => 14011 OK := (not Is_Fun and then Num_F = 2); 14012 14013 when others => 14014 OK := False; 14015 end case; 14016 14017 if not OK then 14018 Error_Msg_N ("attribute reference has wrong profile for subprogram", 14019 Def); 14020 end if; 14021 end Valid_Default_Attribute; 14022 14023end Sem_Ch12; 14024