1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 1 2 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Contracts; use Contracts; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Expander; use Expander; 33with Fname; use Fname; 34with Fname.UF; use Fname.UF; 35with Freeze; use Freeze; 36with Ghost; use Ghost; 37with Itypes; use Itypes; 38with Lib; use Lib; 39with Lib.Load; use Lib.Load; 40with Lib.Xref; use Lib.Xref; 41with Nlists; use Nlists; 42with Namet; use Namet; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Rident; use Rident; 46with Restrict; use Restrict; 47with Rtsfind; use Rtsfind; 48with Sem; use Sem; 49with Sem_Aux; use Sem_Aux; 50with Sem_Cat; use Sem_Cat; 51with Sem_Ch3; use Sem_Ch3; 52with Sem_Ch6; use Sem_Ch6; 53with Sem_Ch7; use Sem_Ch7; 54with Sem_Ch8; use Sem_Ch8; 55with Sem_Ch10; use Sem_Ch10; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Dim; use Sem_Dim; 58with Sem_Disp; use Sem_Disp; 59with Sem_Elab; use Sem_Elab; 60with Sem_Elim; use Sem_Elim; 61with Sem_Eval; use Sem_Eval; 62with Sem_Prag; use Sem_Prag; 63with Sem_Res; use Sem_Res; 64with Sem_Type; use Sem_Type; 65with Sem_Util; use Sem_Util; 66with Sem_Warn; use Sem_Warn; 67with Stand; use Stand; 68with Sinfo; use Sinfo; 69with Sinfo.CN; use Sinfo.CN; 70with Sinput; use Sinput; 71with Sinput.L; use Sinput.L; 72with Snames; use Snames; 73with Stringt; use Stringt; 74with Uname; use Uname; 75with Table; 76with Tbuild; use Tbuild; 77with Uintp; use Uintp; 78with Urealp; use Urealp; 79with Warnsw; use Warnsw; 80 81with GNAT.HTable; 82 83package body Sem_Ch12 is 84 85 ---------------------------------------------------------- 86 -- Implementation of Generic Analysis and Instantiation -- 87 ---------------------------------------------------------- 88 89 -- GNAT implements generics by macro expansion. No attempt is made to share 90 -- generic instantiations (for now). Analysis of a generic definition does 91 -- not perform any expansion action, but the expander must be called on the 92 -- tree for each instantiation, because the expansion may of course depend 93 -- on the generic actuals. All of this is best achieved as follows: 94 -- 95 -- a) Semantic analysis of a generic unit is performed on a copy of the 96 -- tree for the generic unit. All tree modifications that follow analysis 97 -- do not affect the original tree. Links are kept between the original 98 -- tree and the copy, in order to recognize non-local references within 99 -- the generic, and propagate them to each instance (recall that name 100 -- resolution is done on the generic declaration: generics are not really 101 -- macros). This is summarized in the following diagram: 102 103 -- .-----------. .----------. 104 -- | semantic |<--------------| generic | 105 -- | copy | | unit | 106 -- | |==============>| | 107 -- |___________| global |__________| 108 -- references | | | 109 -- | | | 110 -- .-----|--|. 111 -- | .-----|---. 112 -- | | .----------. 113 -- | | | generic | 114 -- |__| | | 115 -- |__| instance | 116 -- |__________| 117 118 -- b) Each instantiation copies the original tree, and inserts into it a 119 -- series of declarations that describe the mapping between generic formals 120 -- and actuals. For example, a generic In OUT parameter is an object 121 -- renaming of the corresponding actual, etc. Generic IN parameters are 122 -- constant declarations. 123 124 -- c) In order to give the right visibility for these renamings, we use 125 -- a different scheme for package and subprogram instantiations. For 126 -- packages, the list of renamings is inserted into the package 127 -- specification, before the visible declarations of the package. The 128 -- renamings are analyzed before any of the text of the instance, and are 129 -- thus visible at the right place. Furthermore, outside of the instance, 130 -- the generic parameters are visible and denote their corresponding 131 -- actuals. 132 133 -- For subprograms, we create a container package to hold the renamings 134 -- and the subprogram instance itself. Analysis of the package makes the 135 -- renaming declarations visible to the subprogram. After analyzing the 136 -- package, the defining entity for the subprogram is touched-up so that 137 -- it appears declared in the current scope, and not inside the container 138 -- package. 139 140 -- If the instantiation is a compilation unit, the container package is 141 -- given the same name as the subprogram instance. This ensures that 142 -- the elaboration procedure called by the binder, using the compilation 143 -- unit name, calls in fact the elaboration procedure for the package. 144 145 -- Not surprisingly, private types complicate this approach. By saving in 146 -- the original generic object the non-local references, we guarantee that 147 -- the proper entities are referenced at the point of instantiation. 148 -- However, for private types, this by itself does not insure that the 149 -- proper VIEW of the entity is used (the full type may be visible at the 150 -- point of generic definition, but not at instantiation, or vice-versa). 151 -- In order to reference the proper view, we special-case any reference 152 -- to private types in the generic object, by saving both views, one in 153 -- the generic and one in the semantic copy. At time of instantiation, we 154 -- check whether the two views are consistent, and exchange declarations if 155 -- necessary, in order to restore the correct visibility. Similarly, if 156 -- the instance view is private when the generic view was not, we perform 157 -- the exchange. After completing the instantiation, we restore the 158 -- current visibility. The flag Has_Private_View marks identifiers in the 159 -- the generic unit that require checking. 160 161 -- Visibility within nested generic units requires special handling. 162 -- Consider the following scheme: 163 164 -- type Global is ... -- outside of generic unit. 165 -- generic ... 166 -- package Outer is 167 -- ... 168 -- type Semi_Global is ... -- global to inner. 169 170 -- generic ... -- 1 171 -- procedure inner (X1 : Global; X2 : Semi_Global); 172 173 -- procedure in2 is new inner (...); -- 4 174 -- end Outer; 175 176 -- package New_Outer is new Outer (...); -- 2 177 -- procedure New_Inner is new New_Outer.Inner (...); -- 3 178 179 -- The semantic analysis of Outer captures all occurrences of Global. 180 -- The semantic analysis of Inner (at 1) captures both occurrences of 181 -- Global and Semi_Global. 182 183 -- At point 2 (instantiation of Outer), we also produce a generic copy 184 -- of Inner, even though Inner is, at that point, not being instantiated. 185 -- (This is just part of the semantic analysis of New_Outer). 186 187 -- Critically, references to Global within Inner must be preserved, while 188 -- references to Semi_Global should not preserved, because they must now 189 -- resolve to an entity within New_Outer. To distinguish between these, we 190 -- use a global variable, Current_Instantiated_Parent, which is set when 191 -- performing a generic copy during instantiation (at 2). This variable is 192 -- used when performing a generic copy that is not an instantiation, but 193 -- that is nested within one, as the occurrence of 1 within 2. The analysis 194 -- of a nested generic only preserves references that are global to the 195 -- enclosing Current_Instantiated_Parent. We use the Scope_Depth value to 196 -- determine whether a reference is external to the given parent. 197 198 -- The instantiation at point 3 requires no special treatment. The method 199 -- works as well for further nestings of generic units, but of course the 200 -- variable Current_Instantiated_Parent must be stacked because nested 201 -- instantiations can occur, e.g. the occurrence of 4 within 2. 202 203 -- The instantiation of package and subprogram bodies is handled in a 204 -- similar manner, except that it is delayed until after semantic 205 -- analysis is complete. In this fashion complex cross-dependencies 206 -- between several package declarations and bodies containing generics 207 -- can be compiled which otherwise would diagnose spurious circularities. 208 209 -- For example, it is possible to compile two packages A and B that 210 -- have the following structure: 211 212 -- package A is package B is 213 -- generic ... generic ... 214 -- package G_A is package G_B is 215 216 -- with B; with A; 217 -- package body A is package body B is 218 -- package N_B is new G_B (..) package N_A is new G_A (..) 219 220 -- The table Pending_Instantiations in package Inline is used to keep 221 -- track of body instantiations that are delayed in this manner. Inline 222 -- handles the actual calls to do the body instantiations. This activity 223 -- is part of Inline, since the processing occurs at the same point, and 224 -- for essentially the same reason, as the handling of inlined routines. 225 226 ---------------------------------------------- 227 -- Detection of Instantiation Circularities -- 228 ---------------------------------------------- 229 230 -- If we have a chain of instantiations that is circular, this is static 231 -- error which must be detected at compile time. The detection of these 232 -- circularities is carried out at the point that we insert a generic 233 -- instance spec or body. If there is a circularity, then the analysis of 234 -- the offending spec or body will eventually result in trying to load the 235 -- same unit again, and we detect this problem as we analyze the package 236 -- instantiation for the second time. 237 238 -- At least in some cases after we have detected the circularity, we get 239 -- into trouble if we try to keep going. The following flag is set if a 240 -- circularity is detected, and used to abandon compilation after the 241 -- messages have been posted. 242 243 Circularity_Detected : Boolean := False; 244 -- It should really be reset upon encountering a new main unit, but in 245 -- practice we do not use multiple main units so this is not critical. 246 247 ----------------------------------------- 248 -- Implementation of Generic Contracts -- 249 ----------------------------------------- 250 251 -- A "contract" is a collection of aspects and pragmas that either verify a 252 -- property of a construct at runtime or classify the data flow to and from 253 -- the construct in some fashion. 254 255 -- Generic packages, subprograms and their respective bodies may be subject 256 -- to the following contract-related aspects or pragmas collectively known 257 -- as annotations: 258 259 -- package subprogram [body] 260 -- Abstract_State Contract_Cases 261 -- Initial_Condition Depends 262 -- Initializes Extensions_Visible 263 -- Global 264 -- package body Post 265 -- Refined_State Post_Class 266 -- Postcondition 267 -- Pre 268 -- Pre_Class 269 -- Precondition 270 -- Refined_Depends 271 -- Refined_Global 272 -- Refined_Post 273 -- Test_Case 274 275 -- Most package contract annotations utilize forward references to classify 276 -- data declared within the package [body]. Subprogram annotations then use 277 -- the classifications to further refine them. These inter dependencies are 278 -- problematic with respect to the implementation of generics because their 279 -- analysis, capture of global references and instantiation does not mesh 280 -- well with the existing mechanism. 281 282 -- 1) Analysis of generic contracts is carried out the same way non-generic 283 -- contracts are analyzed: 284 285 -- 1.1) General rule - a contract is analyzed after all related aspects 286 -- and pragmas are analyzed. This is done by routines 287 288 -- Analyze_Package_Body_Contract 289 -- Analyze_Package_Contract 290 -- Analyze_Subprogram_Body_Contract 291 -- Analyze_Subprogram_Contract 292 293 -- 1.2) Compilation unit - the contract is analyzed after Pragmas_After 294 -- are processed. 295 296 -- 1.3) Compilation unit body - the contract is analyzed at the end of 297 -- the body declaration list. 298 299 -- 1.4) Package - the contract is analyzed at the end of the private or 300 -- visible declarations, prior to analyzing the contracts of any nested 301 -- packages or subprograms. 302 303 -- 1.5) Package body - the contract is analyzed at the end of the body 304 -- declaration list, prior to analyzing the contracts of any nested 305 -- packages or subprograms. 306 307 -- 1.6) Subprogram - if the subprogram is declared inside a block, a 308 -- package or a subprogram, then its contract is analyzed at the end of 309 -- the enclosing declarations, otherwise the subprogram is a compilation 310 -- unit 1.2). 311 312 -- 1.7) Subprogram body - if the subprogram body is declared inside a 313 -- block, a package body or a subprogram body, then its contract is 314 -- analyzed at the end of the enclosing declarations, otherwise the 315 -- subprogram is a compilation unit 1.3). 316 317 -- 2) Capture of global references within contracts is done after capturing 318 -- global references within the generic template. There are two reasons for 319 -- this delay - pragma annotations are not part of the generic template in 320 -- the case of a generic subprogram declaration, and analysis of contracts 321 -- is delayed. 322 323 -- Contract-related source pragmas within generic templates are prepared 324 -- for delayed capture of global references by routine 325 326 -- Create_Generic_Contract 327 328 -- The routine associates these pragmas with the contract of the template. 329 -- In the case of a generic subprogram declaration, the routine creates 330 -- generic templates for the pragmas declared after the subprogram because 331 -- they are not part of the template. 332 333 -- generic -- template starts 334 -- procedure Gen_Proc (Input : Integer); -- template ends 335 -- pragma Precondition (Input > 0); -- requires own template 336 337 -- 2.1) The capture of global references with aspect specifications and 338 -- source pragmas that apply to a generic unit must be suppressed when 339 -- the generic template is being processed because the contracts have not 340 -- been analyzed yet. Any attempts to capture global references at that 341 -- point will destroy the Associated_Node linkages and leave the template 342 -- undecorated. This delay is controlled by routine 343 344 -- Requires_Delayed_Save 345 346 -- 2.2) The real capture of global references within a contract is done 347 -- after the contract has been analyzed, by routine 348 349 -- Save_Global_References_In_Contract 350 351 -- 3) The instantiation of a generic contract occurs as part of the 352 -- instantiation of the contract owner. Generic subprogram declarations 353 -- require additional processing when the contract is specified by pragmas 354 -- because the pragmas are not part of the generic template. This is done 355 -- by routine 356 357 -- Instantiate_Subprogram_Contract 358 359 -------------------------------------------------- 360 -- Formal packages and partial parameterization -- 361 -------------------------------------------------- 362 363 -- When compiling a generic, a formal package is a local instantiation. If 364 -- declared with a box, its generic formals are visible in the enclosing 365 -- generic. If declared with a partial list of actuals, those actuals that 366 -- are defaulted (covered by an Others clause, or given an explicit box 367 -- initialization) are also visible in the enclosing generic, while those 368 -- that have a corresponding actual are not. 369 370 -- In our source model of instantiation, the same visibility must be 371 -- present in the spec and body of an instance: the names of the formals 372 -- that are defaulted must be made visible within the instance, and made 373 -- invisible (hidden) after the instantiation is complete, so that they 374 -- are not accessible outside of the instance. 375 376 -- In a generic, a formal package is treated like a special instantiation. 377 -- Our Ada 95 compiler handled formals with and without box in different 378 -- ways. With partial parameterization, we use a single model for both. 379 -- We create a package declaration that consists of the specification of 380 -- the generic package, and a set of declarations that map the actuals 381 -- into local renamings, just as we do for bona fide instantiations. For 382 -- defaulted parameters and formals with a box, we copy directly the 383 -- declarations of the formals into this local package. The result is a 384 -- package whose visible declarations may include generic formals. This 385 -- package is only used for type checking and visibility analysis, and 386 -- never reaches the back end, so it can freely violate the placement 387 -- rules for generic formal declarations. 388 389 -- The list of declarations (renamings and copies of formals) is built 390 -- by Analyze_Associations, just as for regular instantiations. 391 392 -- At the point of instantiation, conformance checking must be applied only 393 -- to those parameters that were specified in the formals. We perform this 394 -- checking by creating another internal instantiation, this one including 395 -- only the renamings and the formals (the rest of the package spec is not 396 -- relevant to conformance checking). We can then traverse two lists: the 397 -- list of actuals in the instance that corresponds to the formal package, 398 -- and the list of actuals produced for this bogus instantiation. We apply 399 -- the conformance rules to those actuals that are not defaulted, i.e. 400 -- which still appear as generic formals. 401 402 -- When we compile an instance body we must make the right parameters 403 -- visible again. The predicate Is_Generic_Formal indicates which of the 404 -- formals should have its Is_Hidden flag reset. 405 406 ----------------------- 407 -- Local subprograms -- 408 ----------------------- 409 410 procedure Abandon_Instantiation (N : Node_Id); 411 pragma No_Return (Abandon_Instantiation); 412 -- Posts an error message "instantiation abandoned" at the indicated node 413 -- and then raises the exception Instantiation_Error to do it. 414 415 procedure Analyze_Formal_Array_Type 416 (T : in out Entity_Id; 417 Def : Node_Id); 418 -- A formal array type is treated like an array type declaration, and 419 -- invokes Array_Type_Declaration (sem_ch3) whose first parameter is 420 -- in-out, because in the case of an anonymous type the entity is 421 -- actually created in the procedure. 422 423 -- The following procedures treat other kinds of formal parameters 424 425 procedure Analyze_Formal_Derived_Interface_Type 426 (N : Node_Id; 427 T : Entity_Id; 428 Def : Node_Id); 429 430 procedure Analyze_Formal_Derived_Type 431 (N : Node_Id; 432 T : Entity_Id; 433 Def : Node_Id); 434 435 procedure Analyze_Formal_Interface_Type 436 (N : Node_Id; 437 T : Entity_Id; 438 Def : Node_Id); 439 440 -- The following subprograms create abbreviated declarations for formal 441 -- scalar types. We introduce an anonymous base of the proper class for 442 -- each of them, and define the formals as constrained first subtypes of 443 -- their bases. The bounds are expressions that are non-static in the 444 -- generic. 445 446 procedure Analyze_Formal_Decimal_Fixed_Point_Type 447 (T : Entity_Id; Def : Node_Id); 448 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); 449 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); 450 procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); 451 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); 452 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 453 (T : Entity_Id; Def : Node_Id); 454 455 procedure Analyze_Formal_Private_Type 456 (N : Node_Id; 457 T : Entity_Id; 458 Def : Node_Id); 459 -- Creates a new private type, which does not require completion 460 461 procedure Analyze_Formal_Incomplete_Type (T : Entity_Id; Def : Node_Id); 462 -- Ada 2012: Creates a new incomplete type whose actual does not freeze 463 464 procedure Analyze_Generic_Formal_Part (N : Node_Id); 465 -- Analyze generic formal part 466 467 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); 468 -- Create a new access type with the given designated type 469 470 function Analyze_Associations 471 (I_Node : Node_Id; 472 Formals : List_Id; 473 F_Copy : List_Id) return List_Id; 474 -- At instantiation time, build the list of associations between formals 475 -- and actuals. Each association becomes a renaming declaration for the 476 -- formal entity. F_Copy is the analyzed list of formals in the generic 477 -- copy. It is used to apply legality checks to the actuals. I_Node is the 478 -- instantiation node itself. 479 480 procedure Analyze_Subprogram_Instantiation 481 (N : Node_Id; 482 K : Entity_Kind); 483 484 procedure Build_Instance_Compilation_Unit_Nodes 485 (N : Node_Id; 486 Act_Body : Node_Id; 487 Act_Decl : Node_Id); 488 -- This procedure is used in the case where the generic instance of a 489 -- subprogram body or package body is a library unit. In this case, the 490 -- original library unit node for the generic instantiation must be 491 -- replaced by the resulting generic body, and a link made to a new 492 -- compilation unit node for the generic declaration. The argument N is 493 -- the original generic instantiation. Act_Body and Act_Decl are the body 494 -- and declaration of the instance (either package body and declaration 495 -- nodes or subprogram body and declaration nodes depending on the case). 496 -- On return, the node N has been rewritten with the actual body. 497 498 procedure Check_Access_Definition (N : Node_Id); 499 -- Subsidiary routine to null exclusion processing. Perform an assertion 500 -- check on Ada version and the presence of an access definition in N. 501 502 procedure Check_Formal_Packages (P_Id : Entity_Id); 503 -- Apply the following to all formal packages in generic associations. 504 -- Restore the visibility of the formals of the instance that are not 505 -- defaulted (see RM 12.7 (10)). Remove the anonymous package declaration 506 -- created for formal instances that are not defaulted. 507 508 procedure Check_Formal_Package_Instance 509 (Formal_Pack : Entity_Id; 510 Actual_Pack : Entity_Id); 511 -- Verify that the actuals of the actual instance match the actuals of 512 -- the template for a formal package that is not declared with a box. 513 514 procedure Check_Forward_Instantiation (Decl : Node_Id); 515 -- If the generic is a local entity and the corresponding body has not 516 -- been seen yet, flag enclosing packages to indicate that it will be 517 -- elaborated after the generic body. Subprograms declared in the same 518 -- package cannot be inlined by the front end because front-end inlining 519 -- requires a strict linear order of elaboration. 520 521 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; 522 -- Check if some association between formals and actuals requires to make 523 -- visible primitives of a tagged type, and make those primitives visible. 524 -- Return the list of primitives whose visibility is modified (to restore 525 -- their visibility later through Restore_Hidden_Primitives). If no 526 -- candidate is found then return No_Elist. 527 528 procedure Check_Hidden_Child_Unit 529 (N : Node_Id; 530 Gen_Unit : Entity_Id; 531 Act_Decl_Id : Entity_Id); 532 -- If the generic unit is an implicit child instance within a parent 533 -- instance, we need to make an explicit test that it is not hidden by 534 -- a child instance of the same name and parent. 535 536 procedure Check_Generic_Actuals 537 (Instance : Entity_Id; 538 Is_Formal_Box : Boolean); 539 -- Similar to previous one. Check the actuals in the instantiation, 540 -- whose views can change between the point of instantiation and the point 541 -- of instantiation of the body. In addition, mark the generic renamings 542 -- as generic actuals, so that they are not compatible with other actuals. 543 -- Recurse on an actual that is a formal package whose declaration has 544 -- a box. 545 546 function Contains_Instance_Of 547 (Inner : Entity_Id; 548 Outer : Entity_Id; 549 N : Node_Id) return Boolean; 550 -- Inner is instantiated within the generic Outer. Check whether Inner 551 -- directly or indirectly contains an instance of Outer or of one of its 552 -- parents, in the case of a subunit. Each generic unit holds a list of 553 -- the entities instantiated within (at any depth). This procedure 554 -- determines whether the set of such lists contains a cycle, i.e. an 555 -- illegal circular instantiation. 556 557 function Denotes_Formal_Package 558 (Pack : Entity_Id; 559 On_Exit : Boolean := False; 560 Instance : Entity_Id := Empty) return Boolean; 561 -- Returns True if E is a formal package of an enclosing generic, or 562 -- the actual for such a formal in an enclosing instantiation. If such 563 -- a package is used as a formal in an nested generic, or as an actual 564 -- in a nested instantiation, the visibility of ITS formals should not 565 -- be modified. When called from within Restore_Private_Views, the flag 566 -- On_Exit is true, to indicate that the search for a possible enclosing 567 -- instance should ignore the current one. In that case Instance denotes 568 -- the declaration for which this is an actual. This declaration may be 569 -- an instantiation in the source, or the internal instantiation that 570 -- corresponds to the actual for a formal package. 571 572 function Earlier (N1, N2 : Node_Id) return Boolean; 573 -- Yields True if N1 and N2 appear in the same compilation unit, 574 -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right 575 -- traversal of the tree for the unit. Used to determine the placement 576 -- of freeze nodes for instance bodies that may depend on other instances. 577 578 function Find_Actual_Type 579 (Typ : Entity_Id; 580 Gen_Type : Entity_Id) return Entity_Id; 581 -- When validating the actual types of a child instance, check whether 582 -- the formal is a formal type of the parent unit, and retrieve the current 583 -- actual for it. Typ is the entity in the analyzed formal type declaration 584 -- (component or index type of an array type, or designated type of an 585 -- access formal) and Gen_Type is the enclosing analyzed formal array 586 -- or access type. The desired actual may be a formal of a parent, or may 587 -- be declared in a formal package of a parent. In both cases it is a 588 -- generic actual type because it appears within a visible instance. 589 -- Finally, it may be declared in a parent unit without being a formal 590 -- of that unit, in which case it must be retrieved by visibility. 591 -- Ambiguities may still arise if two homonyms are declared in two formal 592 -- packages, and the prefix of the formal type may be needed to resolve 593 -- the ambiguity in the instance ??? 594 595 procedure Freeze_Subprogram_Body 596 (Inst_Node : Node_Id; 597 Gen_Body : Node_Id; 598 Pack_Id : Entity_Id); 599 -- The generic body may appear textually after the instance, including 600 -- in the proper body of a stub, or within a different package instance. 601 -- Given that the instance can only be elaborated after the generic, we 602 -- place freeze_nodes for the instance and/or for packages that may enclose 603 -- the instance and the generic, so that the back-end can establish the 604 -- proper order of elaboration. 605 606 function Get_Associated_Node (N : Node_Id) return Node_Id; 607 -- In order to propagate semantic information back from the analyzed copy 608 -- to the original generic, we maintain links between selected nodes in the 609 -- generic and their corresponding copies. At the end of generic analysis, 610 -- the routine Save_Global_References traverses the generic tree, examines 611 -- the semantic information, and preserves the links to those nodes that 612 -- contain global information. At instantiation, the information from the 613 -- associated node is placed on the new copy, so that name resolution is 614 -- not repeated. 615 -- 616 -- Three kinds of source nodes have associated nodes: 617 -- 618 -- a) those that can reference (denote) entities, that is identifiers, 619 -- character literals, expanded_names, operator symbols, operators, 620 -- and attribute reference nodes. These nodes have an Entity field 621 -- and are the set of nodes that are in N_Has_Entity. 622 -- 623 -- b) aggregates (N_Aggregate and N_Extension_Aggregate) 624 -- 625 -- c) selected components (N_Selected_Component) 626 -- 627 -- For the first class, the associated node preserves the entity if it is 628 -- global. If the generic contains nested instantiations, the associated 629 -- node itself has been recopied, and a chain of them must be followed. 630 -- 631 -- For aggregates, the associated node allows retrieval of the type, which 632 -- may otherwise not appear in the generic. The view of this type may be 633 -- different between generic and instantiation, and the full view can be 634 -- installed before the instantiation is analyzed. For aggregates of type 635 -- extensions, the same view exchange may have to be performed for some of 636 -- the ancestor types, if their view is private at the point of 637 -- instantiation. 638 -- 639 -- Nodes that are selected components in the parse tree may be rewritten 640 -- as expanded names after resolution, and must be treated as potential 641 -- entity holders, which is why they also have an Associated_Node. 642 -- 643 -- Nodes that do not come from source, such as freeze nodes, do not appear 644 -- in the generic tree, and need not have an associated node. 645 -- 646 -- The associated node is stored in the Associated_Node field. Note that 647 -- this field overlaps Entity, which is fine, because the whole point is 648 -- that we don't need or want the normal Entity field in this situation. 649 650 function Has_Been_Exchanged (E : Entity_Id) return Boolean; 651 -- Traverse the Exchanged_Views list to see if a type was private 652 -- and has already been flipped during this phase of instantiation. 653 654 procedure Hide_Current_Scope; 655 -- When instantiating a generic child unit, the parent context must be 656 -- present, but the instance and all entities that may be generated 657 -- must be inserted in the current scope. We leave the current scope 658 -- on the stack, but make its entities invisible to avoid visibility 659 -- problems. This is reversed at the end of the instantiation. This is 660 -- not done for the instantiation of the bodies, which only require the 661 -- instances of the generic parents to be in scope. 662 663 function In_Main_Context (E : Entity_Id) return Boolean; 664 -- Check whether an instantiation is in the context of the main unit. 665 -- Used to determine whether its body should be elaborated to allow 666 -- front-end inlining. 667 668 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); 669 -- Add the context clause of the unit containing a generic unit to a 670 -- compilation unit that is, or contains, an instantiation. 671 672 procedure Init_Env; 673 -- Establish environment for subsequent instantiation. Separated from 674 -- Save_Env because data-structures for visibility handling must be 675 -- initialized before call to Check_Generic_Child_Unit. 676 677 procedure Inline_Instance_Body 678 (N : Node_Id; 679 Gen_Unit : Entity_Id; 680 Act_Decl : Node_Id); 681 -- If front-end inlining is requested, instantiate the package body, 682 -- and preserve the visibility of its compilation unit, to insure 683 -- that successive instantiations succeed. 684 685 procedure Insert_Freeze_Node_For_Instance 686 (N : Node_Id; 687 F_Node : Node_Id); 688 -- N denotes a package or a subprogram instantiation and F_Node is the 689 -- associated freeze node. Insert the freeze node before the first source 690 -- body which follows immediately after N. If no such body is found, the 691 -- freeze node is inserted at the end of the declarative region which 692 -- contains N. 693 694 procedure Install_Body 695 (Act_Body : Node_Id; 696 N : Node_Id; 697 Gen_Body : Node_Id; 698 Gen_Decl : Node_Id); 699 -- If the instantiation happens textually before the body of the generic, 700 -- the instantiation of the body must be analyzed after the generic body, 701 -- and not at the point of instantiation. Such early instantiations can 702 -- happen if the generic and the instance appear in a package declaration 703 -- because the generic body can only appear in the corresponding package 704 -- body. Early instantiations can also appear if generic, instance and 705 -- body are all in the declarative part of a subprogram or entry. Entities 706 -- of packages that are early instantiations are delayed, and their freeze 707 -- node appears after the generic body. This rather complex machinery is 708 -- needed when nested instantiations are present, because the source does 709 -- not carry any indication of where the corresponding instance bodies must 710 -- be installed and frozen. 711 712 procedure Install_Formal_Packages (Par : Entity_Id); 713 -- Install the visible part of any formal of the parent that is a formal 714 -- package. Note that for the case of a formal package with a box, this 715 -- includes the formal part of the formal package (12.7(10/2)). 716 717 procedure Install_Hidden_Primitives 718 (Prims_List : in out Elist_Id; 719 Gen_T : Entity_Id; 720 Act_T : Entity_Id); 721 -- Remove suffix 'P' from hidden primitives of Act_T to match the 722 -- visibility of primitives of Gen_T. The list of primitives to which 723 -- the suffix is removed is added to Prims_List to restore them later. 724 725 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False); 726 -- When compiling an instance of a child unit the parent (which is 727 -- itself an instance) is an enclosing scope that must be made 728 -- immediately visible. This procedure is also used to install the non- 729 -- generic parent of a generic child unit when compiling its body, so 730 -- that full views of types in the parent are made visible. 731 732 -- The functions Instantiate_XXX perform various legality checks and build 733 -- the declarations for instantiated generic parameters. In all of these 734 -- Formal is the entity in the generic unit, Actual is the entity of 735 -- expression in the generic associations, and Analyzed_Formal is the 736 -- formal in the generic copy, which contains the semantic information to 737 -- be used to validate the actual. 738 739 function Instantiate_Object 740 (Formal : Node_Id; 741 Actual : Node_Id; 742 Analyzed_Formal : Node_Id) return List_Id; 743 744 function Instantiate_Type 745 (Formal : Node_Id; 746 Actual : Node_Id; 747 Analyzed_Formal : Node_Id; 748 Actual_Decls : List_Id) return List_Id; 749 750 function Instantiate_Formal_Subprogram 751 (Formal : Node_Id; 752 Actual : Node_Id; 753 Analyzed_Formal : Node_Id) return Node_Id; 754 755 function Instantiate_Formal_Package 756 (Formal : Node_Id; 757 Actual : Node_Id; 758 Analyzed_Formal : Node_Id) return List_Id; 759 -- If the formal package is declared with a box, special visibility rules 760 -- apply to its formals: they are in the visible part of the package. This 761 -- is true in the declarative region of the formal package, that is to say 762 -- in the enclosing generic or instantiation. For an instantiation, the 763 -- parameters of the formal package are made visible in an explicit step. 764 -- Furthermore, if the actual has a visible USE clause, these formals must 765 -- be made potentially use-visible as well. On exit from the enclosing 766 -- instantiation, the reverse must be done. 767 768 -- For a formal package declared without a box, there are conformance rules 769 -- that apply to the actuals in the generic declaration and the actuals of 770 -- the actual package in the enclosing instantiation. The simplest way to 771 -- apply these rules is to repeat the instantiation of the formal package 772 -- in the context of the enclosing instance, and compare the generic 773 -- associations of this instantiation with those of the actual package. 774 -- This internal instantiation only needs to contain the renamings of the 775 -- formals: the visible and private declarations themselves need not be 776 -- created. 777 778 -- In Ada 2005, the formal package may be only partially parameterized. 779 -- In that case the visibility step must make visible those actuals whose 780 -- corresponding formals were given with a box. A final complication 781 -- involves inherited operations from formal derived types, which must 782 -- be visible if the type is. 783 784 function Is_In_Main_Unit (N : Node_Id) return Boolean; 785 -- Test if given node is in the main unit 786 787 procedure Load_Parent_Of_Generic 788 (N : Node_Id; 789 Spec : Node_Id; 790 Body_Optional : Boolean := False); 791 -- If the generic appears in a separate non-generic library unit, load the 792 -- corresponding body to retrieve the body of the generic. N is the node 793 -- for the generic instantiation, Spec is the generic package declaration. 794 -- 795 -- Body_Optional is a flag that indicates that the body is being loaded to 796 -- ensure that temporaries are generated consistently when there are other 797 -- instances in the current declarative part that precede the one being 798 -- loaded. In that case a missing body is acceptable. 799 800 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); 801 -- Within the generic part, entities in the formal package are 802 -- visible. To validate subsequent type declarations, indicate 803 -- the correspondence between the entities in the analyzed formal, 804 -- and the entities in the actual package. There are three packages 805 -- involved in the instantiation of a formal package: the parent 806 -- generic P1 which appears in the generic declaration, the fake 807 -- instantiation P2 which appears in the analyzed generic, and whose 808 -- visible entities may be used in subsequent formals, and the actual 809 -- P3 in the instance. To validate subsequent formals, me indicate 810 -- that the entities in P2 are mapped into those of P3. The mapping of 811 -- entities has to be done recursively for nested packages. 812 813 procedure Move_Freeze_Nodes 814 (Out_Of : Entity_Id; 815 After : Node_Id; 816 L : List_Id); 817 -- Freeze nodes can be generated in the analysis of a generic unit, but 818 -- will not be seen by the back-end. It is necessary to move those nodes 819 -- to the enclosing scope if they freeze an outer entity. We place them 820 -- at the end of the enclosing generic package, which is semantically 821 -- neutral. 822 823 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty); 824 -- Analyze actuals to perform name resolution. Full resolution is done 825 -- later, when the expected types are known, but names have to be captured 826 -- before installing parents of generics, that are not visible for the 827 -- actuals themselves. 828 -- 829 -- If Inst is present, it is the entity of the package instance. This 830 -- entity is marked as having a limited_view actual when some actual is 831 -- a limited view. This is used to place the instance body properly. 832 833 procedure Provide_Completing_Bodies (N : Node_Id); 834 -- Generate completing bodies for all subprograms found within package or 835 -- subprogram declaration N. 836 837 procedure Remove_Parent (In_Body : Boolean := False); 838 -- Reverse effect after instantiation of child is complete 839 840 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); 841 -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List 842 -- set to No_Elist. 843 844 procedure Set_Instance_Env 845 (Gen_Unit : Entity_Id; 846 Act_Unit : Entity_Id); 847 -- Save current instance on saved environment, to be used to determine 848 -- the global status of entities in nested instances. Part of Save_Env. 849 -- called after verifying that the generic unit is legal for the instance, 850 -- The procedure also examines whether the generic unit is a predefined 851 -- unit, in order to set configuration switches accordingly. As a result 852 -- the procedure must be called after analyzing and freezing the actuals. 853 854 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id); 855 -- Associate analyzed generic parameter with corresponding instance. Used 856 -- for semantic checks at instantiation time. 857 858 function True_Parent (N : Node_Id) return Node_Id; 859 -- For a subunit, return parent of corresponding stub, else return 860 -- parent of node. 861 862 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); 863 -- Verify that an attribute that appears as the default for a formal 864 -- subprogram is a function or procedure with the correct profile. 865 866 ------------------------------------------- 867 -- Data Structures for Generic Renamings -- 868 ------------------------------------------- 869 870 -- The map Generic_Renamings associates generic entities with their 871 -- corresponding actuals. Currently used to validate type instances. It 872 -- will eventually be used for all generic parameters to eliminate the 873 -- need for overload resolution in the instance. 874 875 type Assoc_Ptr is new Int; 876 877 Assoc_Null : constant Assoc_Ptr := -1; 878 879 type Assoc is record 880 Gen_Id : Entity_Id; 881 Act_Id : Entity_Id; 882 Next_In_HTable : Assoc_Ptr; 883 end record; 884 885 package Generic_Renamings is new Table.Table 886 (Table_Component_Type => Assoc, 887 Table_Index_Type => Assoc_Ptr, 888 Table_Low_Bound => 0, 889 Table_Initial => 10, 890 Table_Increment => 100, 891 Table_Name => "Generic_Renamings"); 892 893 -- Variable to hold enclosing instantiation. When the environment is 894 -- saved for a subprogram inlining, the corresponding Act_Id is empty. 895 896 Current_Instantiated_Parent : Assoc := (Empty, Empty, Assoc_Null); 897 898 -- Hash table for associations 899 900 HTable_Size : constant := 37; 901 type HTable_Range is range 0 .. HTable_Size - 1; 902 903 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr); 904 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr; 905 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id; 906 function Hash (F : Entity_Id) return HTable_Range; 907 908 package Generic_Renamings_HTable is new GNAT.HTable.Static_HTable ( 909 Header_Num => HTable_Range, 910 Element => Assoc, 911 Elmt_Ptr => Assoc_Ptr, 912 Null_Ptr => Assoc_Null, 913 Set_Next => Set_Next_Assoc, 914 Next => Next_Assoc, 915 Key => Entity_Id, 916 Get_Key => Get_Gen_Id, 917 Hash => Hash, 918 Equal => "="); 919 920 Exchanged_Views : Elist_Id; 921 -- This list holds the private views that have been exchanged during 922 -- instantiation to restore the visibility of the generic declaration. 923 -- (see comments above). After instantiation, the current visibility is 924 -- reestablished by means of a traversal of this list. 925 926 Hidden_Entities : Elist_Id; 927 -- This list holds the entities of the current scope that are removed 928 -- from immediate visibility when instantiating a child unit. Their 929 -- visibility is restored in Remove_Parent. 930 931 -- Because instantiations can be recursive, the following must be saved 932 -- on entry and restored on exit from an instantiation (spec or body). 933 -- This is done by the two procedures Save_Env and Restore_Env. For 934 -- package and subprogram instantiations (but not for the body instances) 935 -- the action of Save_Env is done in two steps: Init_Env is called before 936 -- Check_Generic_Child_Unit, because setting the parent instances requires 937 -- that the visibility data structures be properly initialized. Once the 938 -- generic is unit is validated, Set_Instance_Env completes Save_Env. 939 940 Parent_Unit_Visible : Boolean := False; 941 -- Parent_Unit_Visible is used when the generic is a child unit, and 942 -- indicates whether the ultimate parent of the generic is visible in the 943 -- instantiation environment. It is used to reset the visibility of the 944 -- parent at the end of the instantiation (see Remove_Parent). 945 946 Instance_Parent_Unit : Entity_Id := Empty; 947 -- This records the ultimate parent unit of an instance of a generic 948 -- child unit and is used in conjunction with Parent_Unit_Visible to 949 -- indicate the unit to which the Parent_Unit_Visible flag corresponds. 950 951 type Instance_Env is record 952 Instantiated_Parent : Assoc; 953 Exchanged_Views : Elist_Id; 954 Hidden_Entities : Elist_Id; 955 Current_Sem_Unit : Unit_Number_Type; 956 Parent_Unit_Visible : Boolean := False; 957 Instance_Parent_Unit : Entity_Id := Empty; 958 Switches : Config_Switches_Type; 959 end record; 960 961 package Instance_Envs is new Table.Table ( 962 Table_Component_Type => Instance_Env, 963 Table_Index_Type => Int, 964 Table_Low_Bound => 0, 965 Table_Initial => 32, 966 Table_Increment => 100, 967 Table_Name => "Instance_Envs"); 968 969 procedure Restore_Private_Views 970 (Pack_Id : Entity_Id; 971 Is_Package : Boolean := True); 972 -- Restore the private views of external types, and unmark the generic 973 -- renamings of actuals, so that they become compatible subtypes again. 974 -- For subprograms, Pack_Id is the package constructed to hold the 975 -- renamings. 976 977 procedure Switch_View (T : Entity_Id); 978 -- Switch the partial and full views of a type and its private 979 -- dependents (i.e. its subtypes and derived types). 980 981 ------------------------------------ 982 -- Structures for Error Reporting -- 983 ------------------------------------ 984 985 Instantiation_Node : Node_Id; 986 -- Used by subprograms that validate instantiation of formal parameters 987 -- where there might be no actual on which to place the error message. 988 -- Also used to locate the instantiation node for generic subunits. 989 990 Instantiation_Error : exception; 991 -- When there is a semantic error in the generic parameter matching, 992 -- there is no point in continuing the instantiation, because the 993 -- number of cascaded errors is unpredictable. This exception aborts 994 -- the instantiation process altogether. 995 996 S_Adjustment : Sloc_Adjustment; 997 -- Offset created for each node in an instantiation, in order to keep 998 -- track of the source position of the instantiation in each of its nodes. 999 -- A subsequent semantic error or warning on a construct of the instance 1000 -- points to both places: the original generic node, and the point of 1001 -- instantiation. See Sinput and Sinput.L for additional details. 1002 1003 ------------------------------------------------------------ 1004 -- Data structure for keeping track when inside a Generic -- 1005 ------------------------------------------------------------ 1006 1007 -- The following table is used to save values of the Inside_A_Generic 1008 -- flag (see spec of Sem) when they are saved by Start_Generic. 1009 1010 package Generic_Flags is new Table.Table ( 1011 Table_Component_Type => Boolean, 1012 Table_Index_Type => Int, 1013 Table_Low_Bound => 0, 1014 Table_Initial => 32, 1015 Table_Increment => 200, 1016 Table_Name => "Generic_Flags"); 1017 1018 --------------------------- 1019 -- Abandon_Instantiation -- 1020 --------------------------- 1021 1022 procedure Abandon_Instantiation (N : Node_Id) is 1023 begin 1024 Error_Msg_N ("\instantiation abandoned!", N); 1025 raise Instantiation_Error; 1026 end Abandon_Instantiation; 1027 1028 ---------------------------------- 1029 -- Adjust_Inherited_Pragma_Sloc -- 1030 ---------------------------------- 1031 1032 procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is 1033 begin 1034 Adjust_Instantiation_Sloc (N, S_Adjustment); 1035 end Adjust_Inherited_Pragma_Sloc; 1036 1037 -------------------------- 1038 -- Analyze_Associations -- 1039 -------------------------- 1040 1041 function Analyze_Associations 1042 (I_Node : Node_Id; 1043 Formals : List_Id; 1044 F_Copy : List_Id) return List_Id 1045 is 1046 Actuals_To_Freeze : constant Elist_Id := New_Elmt_List; 1047 Assoc_List : constant List_Id := New_List; 1048 Default_Actuals : constant List_Id := New_List; 1049 Gen_Unit : constant Entity_Id := 1050 Defining_Entity (Parent (F_Copy)); 1051 1052 Actuals : List_Id; 1053 Actual : Node_Id; 1054 Analyzed_Formal : Node_Id; 1055 First_Named : Node_Id := Empty; 1056 Formal : Node_Id; 1057 Match : Node_Id; 1058 Named : Node_Id; 1059 Saved_Formal : Node_Id; 1060 1061 Default_Formals : constant List_Id := New_List; 1062 -- If an Others_Choice is present, some of the formals may be defaulted. 1063 -- To simplify the treatment of visibility in an instance, we introduce 1064 -- individual defaults for each such formal. These defaults are 1065 -- appended to the list of associations and replace the Others_Choice. 1066 1067 Found_Assoc : Node_Id; 1068 -- Association for the current formal being match. Empty if there are 1069 -- no remaining actuals, or if there is no named association with the 1070 -- name of the formal. 1071 1072 Is_Named_Assoc : Boolean; 1073 Num_Matched : Nat := 0; 1074 Num_Actuals : Nat := 0; 1075 1076 Others_Present : Boolean := False; 1077 Others_Choice : Node_Id := Empty; 1078 -- In Ada 2005, indicates partial parameterization of a formal 1079 -- package. As usual an other association must be last in the list. 1080 1081 procedure Check_Fixed_Point_Actual (Actual : Node_Id); 1082 -- Warn if an actual fixed-point type has user-defined arithmetic 1083 -- operations, but there is no corresponding formal in the generic, 1084 -- in which case the predefined operations will be used. This merits 1085 -- a warning because of the special semantics of fixed point ops. 1086 1087 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id); 1088 -- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance 1089 -- cannot have a named association for it. AI05-0025 extends this rule 1090 -- to formals of formal packages by AI05-0025, and it also applies to 1091 -- box-initialized formals. 1092 1093 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean; 1094 -- Determine whether the parameter types and the return type of Subp 1095 -- are fully defined at the point of instantiation. 1096 1097 function Matching_Actual 1098 (F : Entity_Id; 1099 A_F : Entity_Id) return Node_Id; 1100 -- Find actual that corresponds to a given a formal parameter. If the 1101 -- actuals are positional, return the next one, if any. If the actuals 1102 -- are named, scan the parameter associations to find the right one. 1103 -- A_F is the corresponding entity in the analyzed generic, which is 1104 -- placed on the selector name for ASIS use. 1105 -- 1106 -- In Ada 2005, a named association may be given with a box, in which 1107 -- case Matching_Actual sets Found_Assoc to the generic association, 1108 -- but return Empty for the actual itself. In this case the code below 1109 -- creates a corresponding declaration for the formal. 1110 1111 function Partial_Parameterization return Boolean; 1112 -- Ada 2005: if no match is found for a given formal, check if the 1113 -- association for it includes a box, or whether the associations 1114 -- include an Others clause. 1115 1116 procedure Process_Default (F : Entity_Id); 1117 -- Add a copy of the declaration of generic formal F to the list of 1118 -- associations, and add an explicit box association for F if there 1119 -- is none yet, and the default comes from an Others_Choice. 1120 1121 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean; 1122 -- Determine whether Subp renames one of the subprograms defined in the 1123 -- generated package Standard. 1124 1125 procedure Set_Analyzed_Formal; 1126 -- Find the node in the generic copy that corresponds to a given formal. 1127 -- The semantic information on this node is used to perform legality 1128 -- checks on the actuals. Because semantic analysis can introduce some 1129 -- anonymous entities or modify the declaration node itself, the 1130 -- correspondence between the two lists is not one-one. In addition to 1131 -- anonymous types, the presence a formal equality will introduce an 1132 -- implicit declaration for the corresponding inequality. 1133 1134 ---------------------------------------- 1135 -- Check_Overloaded_Formal_Subprogram -- 1136 ---------------------------------------- 1137 1138 procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id) is 1139 Temp_Formal : Entity_Id; 1140 1141 begin 1142 Temp_Formal := First (Formals); 1143 while Present (Temp_Formal) loop 1144 if Nkind (Temp_Formal) in N_Formal_Subprogram_Declaration 1145 and then Temp_Formal /= Formal 1146 and then 1147 Chars (Defining_Unit_Name (Specification (Formal))) = 1148 Chars (Defining_Unit_Name (Specification (Temp_Formal))) 1149 then 1150 if Present (Found_Assoc) then 1151 Error_Msg_N 1152 ("named association not allowed for overloaded formal", 1153 Found_Assoc); 1154 1155 else 1156 Error_Msg_N 1157 ("named association not allowed for overloaded formal", 1158 Others_Choice); 1159 end if; 1160 1161 Abandon_Instantiation (Instantiation_Node); 1162 end if; 1163 1164 Next (Temp_Formal); 1165 end loop; 1166 end Check_Overloaded_Formal_Subprogram; 1167 1168 ------------------------------- 1169 -- Check_Fixed_Point_Actual -- 1170 ------------------------------- 1171 1172 procedure Check_Fixed_Point_Actual (Actual : Node_Id) is 1173 Typ : constant Entity_Id := Entity (Actual); 1174 Prims : constant Elist_Id := Collect_Primitive_Operations (Typ); 1175 Elem : Elmt_Id; 1176 Formal : Node_Id; 1177 Op : Entity_Id; 1178 1179 begin 1180 -- Locate primitive operations of the type that are arithmetic 1181 -- operations. 1182 1183 Elem := First_Elmt (Prims); 1184 while Present (Elem) loop 1185 if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then 1186 1187 -- Check whether the generic unit has a formal subprogram of 1188 -- the same name. This does not check types but is good enough 1189 -- to justify a warning. 1190 1191 Formal := First_Non_Pragma (Formals); 1192 Op := Alias (Node (Elem)); 1193 1194 while Present (Formal) loop 1195 if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration 1196 and then Chars (Defining_Entity (Formal)) = 1197 Chars (Node (Elem)) 1198 then 1199 exit; 1200 1201 elsif Nkind (Formal) = N_Formal_Package_Declaration then 1202 declare 1203 Assoc : Node_Id; 1204 Ent : Entity_Id; 1205 1206 begin 1207 -- Locate corresponding actual, and check whether it 1208 -- includes a fixed-point type. 1209 1210 Assoc := First (Assoc_List); 1211 while Present (Assoc) loop 1212 exit when 1213 Nkind (Assoc) = N_Package_Renaming_Declaration 1214 and then Chars (Defining_Unit_Name (Assoc)) = 1215 Chars (Defining_Identifier (Formal)); 1216 1217 Next (Assoc); 1218 end loop; 1219 1220 if Present (Assoc) then 1221 1222 -- If formal package declares a fixed-point type, 1223 -- and the user-defined operator is derived from 1224 -- a generic instance package, the fixed-point type 1225 -- does not use the corresponding predefined op. 1226 1227 Ent := First_Entity (Entity (Name (Assoc))); 1228 while Present (Ent) loop 1229 if Is_Fixed_Point_Type (Ent) 1230 and then Present (Op) 1231 and then Is_Generic_Instance (Scope (Op)) 1232 then 1233 return; 1234 end if; 1235 1236 Next_Entity (Ent); 1237 end loop; 1238 end if; 1239 end; 1240 end if; 1241 1242 Next (Formal); 1243 end loop; 1244 1245 if No (Formal) then 1246 Error_Msg_Sloc := Sloc (Node (Elem)); 1247 Error_Msg_NE 1248 ("?instance uses predefined operation, not primitive " 1249 & "operation&#", Actual, Node (Elem)); 1250 end if; 1251 end if; 1252 1253 Next_Elmt (Elem); 1254 end loop; 1255 end Check_Fixed_Point_Actual; 1256 1257 ------------------------------- 1258 -- Has_Fully_Defined_Profile -- 1259 ------------------------------- 1260 1261 function Has_Fully_Defined_Profile (Subp : Entity_Id) return Boolean is 1262 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean; 1263 -- Determine whethet type Typ is fully defined 1264 1265 --------------------------- 1266 -- Is_Fully_Defined_Type -- 1267 --------------------------- 1268 1269 function Is_Fully_Defined_Type (Typ : Entity_Id) return Boolean is 1270 begin 1271 -- A private type without a full view is not fully defined 1272 1273 if Is_Private_Type (Typ) 1274 and then No (Full_View (Typ)) 1275 then 1276 return False; 1277 1278 -- An incomplete type is never fully defined 1279 1280 elsif Is_Incomplete_Type (Typ) then 1281 return False; 1282 1283 -- All other types are fully defined 1284 1285 else 1286 return True; 1287 end if; 1288 end Is_Fully_Defined_Type; 1289 1290 -- Local declarations 1291 1292 Param : Entity_Id; 1293 1294 -- Start of processing for Has_Fully_Defined_Profile 1295 1296 begin 1297 -- Check the parameters 1298 1299 Param := First_Formal (Subp); 1300 while Present (Param) loop 1301 if not Is_Fully_Defined_Type (Etype (Param)) then 1302 return False; 1303 end if; 1304 1305 Next_Formal (Param); 1306 end loop; 1307 1308 -- Check the return type 1309 1310 return Is_Fully_Defined_Type (Etype (Subp)); 1311 end Has_Fully_Defined_Profile; 1312 1313 --------------------- 1314 -- Matching_Actual -- 1315 --------------------- 1316 1317 function Matching_Actual 1318 (F : Entity_Id; 1319 A_F : Entity_Id) return Node_Id 1320 is 1321 Prev : Node_Id; 1322 Act : Node_Id; 1323 1324 begin 1325 Is_Named_Assoc := False; 1326 1327 -- End of list of purely positional parameters 1328 1329 if No (Actual) or else Nkind (Actual) = N_Others_Choice then 1330 Found_Assoc := Empty; 1331 Act := Empty; 1332 1333 -- Case of positional parameter corresponding to current formal 1334 1335 elsif No (Selector_Name (Actual)) then 1336 Found_Assoc := Actual; 1337 Act := Explicit_Generic_Actual_Parameter (Actual); 1338 Num_Matched := Num_Matched + 1; 1339 Next (Actual); 1340 1341 -- Otherwise scan list of named actuals to find the one with the 1342 -- desired name. All remaining actuals have explicit names. 1343 1344 else 1345 Is_Named_Assoc := True; 1346 Found_Assoc := Empty; 1347 Act := Empty; 1348 Prev := Empty; 1349 1350 while Present (Actual) loop 1351 if Nkind (Actual) = N_Others_Choice then 1352 Found_Assoc := Empty; 1353 Act := Empty; 1354 1355 elsif Chars (Selector_Name (Actual)) = Chars (F) then 1356 Set_Entity (Selector_Name (Actual), A_F); 1357 Set_Etype (Selector_Name (Actual), Etype (A_F)); 1358 Generate_Reference (A_F, Selector_Name (Actual)); 1359 1360 Found_Assoc := Actual; 1361 Act := Explicit_Generic_Actual_Parameter (Actual); 1362 Num_Matched := Num_Matched + 1; 1363 exit; 1364 end if; 1365 1366 Prev := Actual; 1367 Next (Actual); 1368 end loop; 1369 1370 -- Reset for subsequent searches. In most cases the named 1371 -- associations are in order. If they are not, we reorder them 1372 -- to avoid scanning twice the same actual. This is not just a 1373 -- question of efficiency: there may be multiple defaults with 1374 -- boxes that have the same name. In a nested instantiation we 1375 -- insert actuals for those defaults, and cannot rely on their 1376 -- names to disambiguate them. 1377 1378 if Actual = First_Named then 1379 Next (First_Named); 1380 1381 elsif Present (Actual) then 1382 Insert_Before (First_Named, Remove_Next (Prev)); 1383 end if; 1384 1385 Actual := First_Named; 1386 end if; 1387 1388 if Is_Entity_Name (Act) and then Present (Entity (Act)) then 1389 Set_Used_As_Generic_Actual (Entity (Act)); 1390 end if; 1391 1392 return Act; 1393 end Matching_Actual; 1394 1395 ------------------------------ 1396 -- Partial_Parameterization -- 1397 ------------------------------ 1398 1399 function Partial_Parameterization return Boolean is 1400 begin 1401 return Others_Present 1402 or else (Present (Found_Assoc) and then Box_Present (Found_Assoc)); 1403 end Partial_Parameterization; 1404 1405 --------------------- 1406 -- Process_Default -- 1407 --------------------- 1408 1409 procedure Process_Default (F : Entity_Id) is 1410 Loc : constant Source_Ptr := Sloc (I_Node); 1411 F_Id : constant Entity_Id := Defining_Entity (F); 1412 Decl : Node_Id; 1413 Default : Node_Id; 1414 Id : Entity_Id; 1415 1416 begin 1417 -- Append copy of formal declaration to associations, and create new 1418 -- defining identifier for it. 1419 1420 Decl := New_Copy_Tree (F); 1421 Id := Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)); 1422 1423 if Nkind (F) in N_Formal_Subprogram_Declaration then 1424 Set_Defining_Unit_Name (Specification (Decl), Id); 1425 1426 else 1427 Set_Defining_Identifier (Decl, Id); 1428 end if; 1429 1430 Append (Decl, Assoc_List); 1431 1432 if No (Found_Assoc) then 1433 Default := 1434 Make_Generic_Association (Loc, 1435 Selector_Name => 1436 New_Occurrence_Of (Id, Loc), 1437 Explicit_Generic_Actual_Parameter => Empty); 1438 Set_Box_Present (Default); 1439 Append (Default, Default_Formals); 1440 end if; 1441 end Process_Default; 1442 1443 --------------------------------- 1444 -- Renames_Standard_Subprogram -- 1445 --------------------------------- 1446 1447 function Renames_Standard_Subprogram (Subp : Entity_Id) return Boolean is 1448 Id : Entity_Id; 1449 1450 begin 1451 Id := Alias (Subp); 1452 while Present (Id) loop 1453 if Scope (Id) = Standard_Standard then 1454 return True; 1455 end if; 1456 1457 Id := Alias (Id); 1458 end loop; 1459 1460 return False; 1461 end Renames_Standard_Subprogram; 1462 1463 ------------------------- 1464 -- Set_Analyzed_Formal -- 1465 ------------------------- 1466 1467 procedure Set_Analyzed_Formal is 1468 Kind : Node_Kind; 1469 1470 begin 1471 while Present (Analyzed_Formal) loop 1472 Kind := Nkind (Analyzed_Formal); 1473 1474 case Nkind (Formal) is 1475 when N_Formal_Subprogram_Declaration => 1476 exit when Kind in N_Formal_Subprogram_Declaration 1477 and then 1478 Chars 1479 (Defining_Unit_Name (Specification (Formal))) = 1480 Chars 1481 (Defining_Unit_Name (Specification (Analyzed_Formal))); 1482 1483 when N_Formal_Package_Declaration => 1484 exit when Nkind_In (Kind, N_Formal_Package_Declaration, 1485 N_Generic_Package_Declaration, 1486 N_Package_Declaration); 1487 1488 when N_Use_Package_Clause 1489 | N_Use_Type_Clause 1490 => 1491 exit; 1492 1493 when others => 1494 1495 -- Skip freeze nodes, and nodes inserted to replace 1496 -- unrecognized pragmas. 1497 1498 exit when 1499 Kind not in N_Formal_Subprogram_Declaration 1500 and then not Nkind_In (Kind, N_Subprogram_Declaration, 1501 N_Freeze_Entity, 1502 N_Null_Statement, 1503 N_Itype_Reference) 1504 and then Chars (Defining_Identifier (Formal)) = 1505 Chars (Defining_Identifier (Analyzed_Formal)); 1506 end case; 1507 1508 Next (Analyzed_Formal); 1509 end loop; 1510 end Set_Analyzed_Formal; 1511 1512 -- Start of processing for Analyze_Associations 1513 1514 begin 1515 Actuals := Generic_Associations (I_Node); 1516 1517 if Present (Actuals) then 1518 1519 -- Check for an Others choice, indicating a partial parameterization 1520 -- for a formal package. 1521 1522 Actual := First (Actuals); 1523 while Present (Actual) loop 1524 if Nkind (Actual) = N_Others_Choice then 1525 Others_Present := True; 1526 Others_Choice := Actual; 1527 1528 if Present (Next (Actual)) then 1529 Error_Msg_N ("others must be last association", Actual); 1530 end if; 1531 1532 -- This subprogram is used both for formal packages and for 1533 -- instantiations. For the latter, associations must all be 1534 -- explicit. 1535 1536 if Nkind (I_Node) /= N_Formal_Package_Declaration 1537 and then Comes_From_Source (I_Node) 1538 then 1539 Error_Msg_N 1540 ("others association not allowed in an instance", 1541 Actual); 1542 end if; 1543 1544 -- In any case, nothing to do after the others association 1545 1546 exit; 1547 1548 elsif Box_Present (Actual) 1549 and then Comes_From_Source (I_Node) 1550 and then Nkind (I_Node) /= N_Formal_Package_Declaration 1551 then 1552 Error_Msg_N 1553 ("box association not allowed in an instance", Actual); 1554 end if; 1555 1556 Next (Actual); 1557 end loop; 1558 1559 -- If named associations are present, save first named association 1560 -- (it may of course be Empty) to facilitate subsequent name search. 1561 1562 First_Named := First (Actuals); 1563 while Present (First_Named) 1564 and then Nkind (First_Named) /= N_Others_Choice 1565 and then No (Selector_Name (First_Named)) 1566 loop 1567 Num_Actuals := Num_Actuals + 1; 1568 Next (First_Named); 1569 end loop; 1570 end if; 1571 1572 Named := First_Named; 1573 while Present (Named) loop 1574 if Nkind (Named) /= N_Others_Choice 1575 and then No (Selector_Name (Named)) 1576 then 1577 Error_Msg_N ("invalid positional actual after named one", Named); 1578 Abandon_Instantiation (Named); 1579 end if; 1580 1581 -- A named association may lack an actual parameter, if it was 1582 -- introduced for a default subprogram that turns out to be local 1583 -- to the outer instantiation. If it has a box association it must 1584 -- correspond to some formal in the generic. 1585 1586 if Nkind (Named) /= N_Others_Choice 1587 and then (Present (Explicit_Generic_Actual_Parameter (Named)) 1588 or else Box_Present (Named)) 1589 then 1590 Num_Actuals := Num_Actuals + 1; 1591 end if; 1592 1593 Next (Named); 1594 end loop; 1595 1596 if Present (Formals) then 1597 Formal := First_Non_Pragma (Formals); 1598 Analyzed_Formal := First_Non_Pragma (F_Copy); 1599 1600 if Present (Actuals) then 1601 Actual := First (Actuals); 1602 1603 -- All formals should have default values 1604 1605 else 1606 Actual := Empty; 1607 end if; 1608 1609 while Present (Formal) loop 1610 Set_Analyzed_Formal; 1611 Saved_Formal := Next_Non_Pragma (Formal); 1612 1613 case Nkind (Formal) is 1614 when N_Formal_Object_Declaration => 1615 Match := 1616 Matching_Actual 1617 (Defining_Identifier (Formal), 1618 Defining_Identifier (Analyzed_Formal)); 1619 1620 if No (Match) and then Partial_Parameterization then 1621 Process_Default (Formal); 1622 1623 else 1624 Append_List 1625 (Instantiate_Object (Formal, Match, Analyzed_Formal), 1626 Assoc_List); 1627 1628 -- For a defaulted in_parameter, create an entry in the 1629 -- the list of defaulted actuals, for GNATProve use. Do 1630 -- not included these defaults for an instance nested 1631 -- within a generic, because the defaults are also used 1632 -- in the analysis of the enclosing generic, and only 1633 -- defaulted subprograms are relevant there. 1634 1635 if No (Match) and then not Inside_A_Generic then 1636 Append_To (Default_Actuals, 1637 Make_Generic_Association (Sloc (I_Node), 1638 Selector_Name => 1639 New_Occurrence_Of 1640 (Defining_Identifier (Formal), Sloc (I_Node)), 1641 Explicit_Generic_Actual_Parameter => 1642 New_Copy_Tree (Default_Expression (Formal)))); 1643 end if; 1644 end if; 1645 1646 -- If the object is a call to an expression function, this 1647 -- is a freezing point for it. 1648 1649 if Is_Entity_Name (Match) 1650 and then Present (Entity (Match)) 1651 and then Nkind 1652 (Original_Node (Unit_Declaration_Node (Entity (Match)))) 1653 = N_Expression_Function 1654 then 1655 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1656 end if; 1657 1658 when N_Formal_Type_Declaration => 1659 Match := 1660 Matching_Actual 1661 (Defining_Identifier (Formal), 1662 Defining_Identifier (Analyzed_Formal)); 1663 1664 if No (Match) then 1665 if Partial_Parameterization then 1666 Process_Default (Formal); 1667 1668 else 1669 Error_Msg_Sloc := Sloc (Gen_Unit); 1670 Error_Msg_NE 1671 ("missing actual&", 1672 Instantiation_Node, Defining_Identifier (Formal)); 1673 Error_Msg_NE 1674 ("\in instantiation of & declared#", 1675 Instantiation_Node, Gen_Unit); 1676 Abandon_Instantiation (Instantiation_Node); 1677 end if; 1678 1679 else 1680 Analyze (Match); 1681 Append_List 1682 (Instantiate_Type 1683 (Formal, Match, Analyzed_Formal, Assoc_List), 1684 Assoc_List); 1685 1686 -- Warn when an actual is a fixed-point with user- 1687 -- defined promitives. The warning is superfluous 1688 -- if the fornal is private, because there can be 1689 -- no arithmetic operations in the generic so there 1690 -- no danger of confusion. 1691 1692 if Is_Fixed_Point_Type (Entity (Match)) 1693 and then not Is_Private_Type 1694 (Defining_Identifier (Analyzed_Formal)) 1695 then 1696 Check_Fixed_Point_Actual (Match); 1697 end if; 1698 1699 -- An instantiation is a freeze point for the actuals, 1700 -- unless this is a rewritten formal package, or the 1701 -- formal is an Ada 2012 formal incomplete type. 1702 1703 if Nkind (I_Node) = N_Formal_Package_Declaration 1704 or else 1705 (Ada_Version >= Ada_2012 1706 and then 1707 Ekind (Defining_Identifier (Analyzed_Formal)) = 1708 E_Incomplete_Type) 1709 then 1710 null; 1711 1712 else 1713 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1714 end if; 1715 end if; 1716 1717 -- A remote access-to-class-wide type is not a legal actual 1718 -- for a generic formal of an access type (E.2.2(17/2)). 1719 -- In GNAT an exception to this rule is introduced when 1720 -- the formal is marked as remote using implementation 1721 -- defined aspect/pragma Remote_Access_Type. In that case 1722 -- the actual must be remote as well. 1723 1724 -- If the current instantiation is the construction of a 1725 -- local copy for a formal package the actuals may be 1726 -- defaulted, and there is no matching actual to check. 1727 1728 if Nkind (Analyzed_Formal) = N_Formal_Type_Declaration 1729 and then 1730 Nkind (Formal_Type_Definition (Analyzed_Formal)) = 1731 N_Access_To_Object_Definition 1732 and then Present (Match) 1733 then 1734 declare 1735 Formal_Ent : constant Entity_Id := 1736 Defining_Identifier (Analyzed_Formal); 1737 begin 1738 if Is_Remote_Access_To_Class_Wide_Type (Entity (Match)) 1739 = Is_Remote_Types (Formal_Ent) 1740 then 1741 -- Remoteness of formal and actual match 1742 1743 null; 1744 1745 elsif Is_Remote_Types (Formal_Ent) then 1746 1747 -- Remote formal, non-remote actual 1748 1749 Error_Msg_NE 1750 ("actual for& must be remote", Match, Formal_Ent); 1751 1752 else 1753 -- Non-remote formal, remote actual 1754 1755 Error_Msg_NE 1756 ("actual for& may not be remote", 1757 Match, Formal_Ent); 1758 end if; 1759 end; 1760 end if; 1761 1762 when N_Formal_Subprogram_Declaration => 1763 Match := 1764 Matching_Actual 1765 (Defining_Unit_Name (Specification (Formal)), 1766 Defining_Unit_Name (Specification (Analyzed_Formal))); 1767 1768 -- If the formal subprogram has the same name as another 1769 -- formal subprogram of the generic, then a named 1770 -- association is illegal (12.3(9)). Exclude named 1771 -- associations that are generated for a nested instance. 1772 1773 if Present (Match) 1774 and then Is_Named_Assoc 1775 and then Comes_From_Source (Found_Assoc) 1776 then 1777 Check_Overloaded_Formal_Subprogram (Formal); 1778 end if; 1779 1780 -- If there is no corresponding actual, this may be case 1781 -- of partial parameterization, or else the formal has a 1782 -- default or a box. 1783 1784 if No (Match) and then Partial_Parameterization then 1785 Process_Default (Formal); 1786 1787 if Nkind (I_Node) = N_Formal_Package_Declaration then 1788 Check_Overloaded_Formal_Subprogram (Formal); 1789 end if; 1790 1791 else 1792 Append_To (Assoc_List, 1793 Instantiate_Formal_Subprogram 1794 (Formal, Match, Analyzed_Formal)); 1795 1796 -- An instantiation is a freeze point for the actuals, 1797 -- unless this is a rewritten formal package. 1798 1799 if Nkind (I_Node) /= N_Formal_Package_Declaration 1800 and then Nkind (Match) = N_Identifier 1801 and then Is_Subprogram (Entity (Match)) 1802 1803 -- The actual subprogram may rename a routine defined 1804 -- in Standard. Avoid freezing such renamings because 1805 -- subprograms coming from Standard cannot be frozen. 1806 1807 and then 1808 not Renames_Standard_Subprogram (Entity (Match)) 1809 1810 -- If the actual subprogram comes from a different 1811 -- unit, it is already frozen, either by a body in 1812 -- that unit or by the end of the declarative part 1813 -- of the unit. This check avoids the freezing of 1814 -- subprograms defined in Standard which are used 1815 -- as generic actuals. 1816 1817 and then In_Same_Code_Unit (Entity (Match), I_Node) 1818 and then Has_Fully_Defined_Profile (Entity (Match)) 1819 then 1820 -- Mark the subprogram as having a delayed freeze 1821 -- since this may be an out-of-order action. 1822 1823 Set_Has_Delayed_Freeze (Entity (Match)); 1824 Append_Elmt (Entity (Match), Actuals_To_Freeze); 1825 end if; 1826 end if; 1827 1828 -- If this is a nested generic, preserve default for later 1829 -- instantiations. We do this as well for GNATProve use, 1830 -- so that the list of generic associations is complete. 1831 1832 if No (Match) and then Box_Present (Formal) then 1833 declare 1834 Subp : constant Entity_Id := 1835 Defining_Unit_Name 1836 (Specification (Last (Assoc_List))); 1837 1838 begin 1839 Append_To (Default_Actuals, 1840 Make_Generic_Association (Sloc (I_Node), 1841 Selector_Name => 1842 New_Occurrence_Of (Subp, Sloc (I_Node)), 1843 Explicit_Generic_Actual_Parameter => 1844 New_Occurrence_Of (Subp, Sloc (I_Node)))); 1845 end; 1846 end if; 1847 1848 when N_Formal_Package_Declaration => 1849 Match := 1850 Matching_Actual 1851 (Defining_Identifier (Formal), 1852 Defining_Identifier (Original_Node (Analyzed_Formal))); 1853 1854 if No (Match) then 1855 if Partial_Parameterization then 1856 Process_Default (Formal); 1857 1858 else 1859 Error_Msg_Sloc := Sloc (Gen_Unit); 1860 Error_Msg_NE 1861 ("missing actual&", 1862 Instantiation_Node, Defining_Identifier (Formal)); 1863 Error_Msg_NE 1864 ("\in instantiation of & declared#", 1865 Instantiation_Node, Gen_Unit); 1866 1867 Abandon_Instantiation (Instantiation_Node); 1868 end if; 1869 1870 else 1871 Analyze (Match); 1872 Append_List 1873 (Instantiate_Formal_Package 1874 (Formal, Match, Analyzed_Formal), 1875 Assoc_List); 1876 1877 -- Determine whether the actual package needs an explicit 1878 -- freeze node. This is only the case if the actual is 1879 -- declared in the same unit and has a body. Normally 1880 -- packages do not have explicit freeze nodes, and gigi 1881 -- only uses them to elaborate entities in a package 1882 -- body. 1883 1884 Explicit_Freeze_Check : declare 1885 Actual : constant Entity_Id := Entity (Match); 1886 Gen_Par : Entity_Id; 1887 1888 Needs_Freezing : Boolean; 1889 S : Entity_Id; 1890 1891 procedure Check_Generic_Parent; 1892 -- The actual may be an instantiation of a unit 1893 -- declared in a previous instantiation. If that 1894 -- one is also in the current compilation, it must 1895 -- itself be frozen before the actual. The actual 1896 -- may be an instantiation of a generic child unit, 1897 -- in which case the same applies to the instance 1898 -- of the parent which must be frozen before the 1899 -- actual. 1900 -- Should this itself be recursive ??? 1901 1902 -------------------------- 1903 -- Check_Generic_Parent -- 1904 -------------------------- 1905 1906 procedure Check_Generic_Parent is 1907 Inst : constant Node_Id := 1908 Next (Unit_Declaration_Node (Actual)); 1909 Par : Entity_Id; 1910 1911 begin 1912 Par := Empty; 1913 1914 if Nkind (Parent (Actual)) = N_Package_Specification 1915 then 1916 Par := Scope (Generic_Parent (Parent (Actual))); 1917 1918 if Is_Generic_Instance (Par) then 1919 null; 1920 1921 -- If the actual is a child generic unit, check 1922 -- whether the instantiation of the parent is 1923 -- also local and must also be frozen now. We 1924 -- must retrieve the instance node to locate the 1925 -- parent instance if any. 1926 1927 elsif Ekind (Par) = E_Generic_Package 1928 and then Is_Child_Unit (Gen_Par) 1929 and then Ekind (Scope (Gen_Par)) = 1930 E_Generic_Package 1931 then 1932 if Nkind (Inst) = N_Package_Instantiation 1933 and then Nkind (Name (Inst)) = 1934 N_Expanded_Name 1935 then 1936 -- Retrieve entity of parent instance 1937 1938 Par := Entity (Prefix (Name (Inst))); 1939 end if; 1940 1941 else 1942 Par := Empty; 1943 end if; 1944 end if; 1945 1946 if Present (Par) 1947 and then Is_Generic_Instance (Par) 1948 and then Scope (Par) = Current_Scope 1949 and then 1950 (No (Freeze_Node (Par)) 1951 or else 1952 not Is_List_Member (Freeze_Node (Par))) 1953 then 1954 Set_Has_Delayed_Freeze (Par); 1955 Append_Elmt (Par, Actuals_To_Freeze); 1956 end if; 1957 end Check_Generic_Parent; 1958 1959 -- Start of processing for Explicit_Freeze_Check 1960 1961 begin 1962 if Present (Renamed_Entity (Actual)) then 1963 Gen_Par := 1964 Generic_Parent (Specification 1965 (Unit_Declaration_Node 1966 (Renamed_Entity (Actual)))); 1967 else 1968 Gen_Par := 1969 Generic_Parent (Specification 1970 (Unit_Declaration_Node (Actual))); 1971 end if; 1972 1973 if not Expander_Active 1974 or else not Has_Completion (Actual) 1975 or else not In_Same_Source_Unit (I_Node, Actual) 1976 or else Is_Frozen (Actual) 1977 or else 1978 (Present (Renamed_Entity (Actual)) 1979 and then 1980 not In_Same_Source_Unit 1981 (I_Node, (Renamed_Entity (Actual)))) 1982 then 1983 null; 1984 1985 else 1986 -- Finally we want to exclude such freeze nodes 1987 -- from statement sequences, which freeze 1988 -- everything before them. 1989 -- Is this strictly necessary ??? 1990 1991 Needs_Freezing := True; 1992 1993 S := Current_Scope; 1994 while Present (S) loop 1995 if Ekind_In (S, E_Block, 1996 E_Function, 1997 E_Loop, 1998 E_Procedure) 1999 then 2000 Needs_Freezing := False; 2001 exit; 2002 end if; 2003 2004 S := Scope (S); 2005 end loop; 2006 2007 if Needs_Freezing then 2008 Check_Generic_Parent; 2009 2010 -- If the actual is a renaming of a proper 2011 -- instance of the formal package, indicate 2012 -- that it is the instance that must be frozen. 2013 2014 if Nkind (Parent (Actual)) = 2015 N_Package_Renaming_Declaration 2016 then 2017 Set_Has_Delayed_Freeze 2018 (Renamed_Entity (Actual)); 2019 Append_Elmt 2020 (Renamed_Entity (Actual), 2021 Actuals_To_Freeze); 2022 else 2023 Set_Has_Delayed_Freeze (Actual); 2024 Append_Elmt (Actual, Actuals_To_Freeze); 2025 end if; 2026 end if; 2027 end if; 2028 end Explicit_Freeze_Check; 2029 end if; 2030 2031 -- For use type and use package appearing in the generic part, 2032 -- we have already copied them, so we can just move them where 2033 -- they belong (we mustn't recopy them since this would mess up 2034 -- the Sloc values). 2035 2036 when N_Use_Package_Clause 2037 | N_Use_Type_Clause 2038 => 2039 if Nkind (Original_Node (I_Node)) = 2040 N_Formal_Package_Declaration 2041 then 2042 Append (New_Copy_Tree (Formal), Assoc_List); 2043 else 2044 Remove (Formal); 2045 Append (Formal, Assoc_List); 2046 end if; 2047 2048 when others => 2049 raise Program_Error; 2050 end case; 2051 2052 Formal := Saved_Formal; 2053 Next_Non_Pragma (Analyzed_Formal); 2054 end loop; 2055 2056 if Num_Actuals > Num_Matched then 2057 Error_Msg_Sloc := Sloc (Gen_Unit); 2058 2059 if Present (Selector_Name (Actual)) then 2060 Error_Msg_NE 2061 ("unmatched actual &", Actual, Selector_Name (Actual)); 2062 Error_Msg_NE 2063 ("\in instantiation of & declared#", Actual, Gen_Unit); 2064 else 2065 Error_Msg_NE 2066 ("unmatched actual in instantiation of & declared#", 2067 Actual, Gen_Unit); 2068 end if; 2069 end if; 2070 2071 elsif Present (Actuals) then 2072 Error_Msg_N 2073 ("too many actuals in generic instantiation", Instantiation_Node); 2074 end if; 2075 2076 -- An instantiation freezes all generic actuals. The only exceptions 2077 -- to this are incomplete types and subprograms which are not fully 2078 -- defined at the point of instantiation. 2079 2080 declare 2081 Elmt : Elmt_Id := First_Elmt (Actuals_To_Freeze); 2082 begin 2083 while Present (Elmt) loop 2084 Freeze_Before (I_Node, Node (Elmt)); 2085 Next_Elmt (Elmt); 2086 end loop; 2087 end; 2088 2089 -- If there are default subprograms, normalize the tree by adding 2090 -- explicit associations for them. This is required if the instance 2091 -- appears within a generic. 2092 2093 if not Is_Empty_List (Default_Actuals) then 2094 declare 2095 Default : Node_Id; 2096 2097 begin 2098 Default := First (Default_Actuals); 2099 while Present (Default) loop 2100 Mark_Rewrite_Insertion (Default); 2101 Next (Default); 2102 end loop; 2103 2104 if No (Actuals) then 2105 Set_Generic_Associations (I_Node, Default_Actuals); 2106 else 2107 Append_List_To (Actuals, Default_Actuals); 2108 end if; 2109 end; 2110 end if; 2111 2112 -- If this is a formal package, normalize the parameter list by adding 2113 -- explicit box associations for the formals that are covered by an 2114 -- Others_Choice. 2115 2116 if not Is_Empty_List (Default_Formals) then 2117 Append_List (Default_Formals, Formals); 2118 end if; 2119 2120 return Assoc_List; 2121 end Analyze_Associations; 2122 2123 ------------------------------- 2124 -- Analyze_Formal_Array_Type -- 2125 ------------------------------- 2126 2127 procedure Analyze_Formal_Array_Type 2128 (T : in out Entity_Id; 2129 Def : Node_Id) 2130 is 2131 DSS : Node_Id; 2132 2133 begin 2134 -- Treated like a non-generic array declaration, with additional 2135 -- semantic checks. 2136 2137 Enter_Name (T); 2138 2139 if Nkind (Def) = N_Constrained_Array_Definition then 2140 DSS := First (Discrete_Subtype_Definitions (Def)); 2141 while Present (DSS) loop 2142 if Nkind_In (DSS, N_Subtype_Indication, 2143 N_Range, 2144 N_Attribute_Reference) 2145 then 2146 Error_Msg_N ("only a subtype mark is allowed in a formal", DSS); 2147 end if; 2148 2149 Next (DSS); 2150 end loop; 2151 end if; 2152 2153 Array_Type_Declaration (T, Def); 2154 Set_Is_Generic_Type (Base_Type (T)); 2155 2156 if Ekind (Component_Type (T)) = E_Incomplete_Type 2157 and then No (Full_View (Component_Type (T))) 2158 then 2159 Error_Msg_N ("premature usage of incomplete type", Def); 2160 2161 -- Check that range constraint is not allowed on the component type 2162 -- of a generic formal array type (AARM 12.5.3(3)) 2163 2164 elsif Is_Internal (Component_Type (T)) 2165 and then Present (Subtype_Indication (Component_Definition (Def))) 2166 and then Nkind (Original_Node 2167 (Subtype_Indication (Component_Definition (Def)))) = 2168 N_Subtype_Indication 2169 then 2170 Error_Msg_N 2171 ("in a formal, a subtype indication can only be " 2172 & "a subtype mark (RM 12.5.3(3))", 2173 Subtype_Indication (Component_Definition (Def))); 2174 end if; 2175 2176 end Analyze_Formal_Array_Type; 2177 2178 --------------------------------------------- 2179 -- Analyze_Formal_Decimal_Fixed_Point_Type -- 2180 --------------------------------------------- 2181 2182 -- As for other generic types, we create a valid type representation with 2183 -- legal but arbitrary attributes, whose values are never considered 2184 -- static. For all scalar types we introduce an anonymous base type, with 2185 -- the same attributes. We choose the corresponding integer type to be 2186 -- Standard_Integer. 2187 -- Here and in other similar routines, the Sloc of the generated internal 2188 -- type must be the same as the sloc of the defining identifier of the 2189 -- formal type declaration, to provide proper source navigation. 2190 2191 procedure Analyze_Formal_Decimal_Fixed_Point_Type 2192 (T : Entity_Id; 2193 Def : Node_Id) 2194 is 2195 Loc : constant Source_Ptr := Sloc (Def); 2196 2197 Base : constant Entity_Id := 2198 New_Internal_Entity 2199 (E_Decimal_Fixed_Point_Type, 2200 Current_Scope, 2201 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2202 2203 Int_Base : constant Entity_Id := Standard_Integer; 2204 Delta_Val : constant Ureal := Ureal_1; 2205 Digs_Val : constant Uint := Uint_6; 2206 2207 function Make_Dummy_Bound return Node_Id; 2208 -- Return a properly typed universal real literal to use as a bound 2209 2210 ---------------------- 2211 -- Make_Dummy_Bound -- 2212 ---------------------- 2213 2214 function Make_Dummy_Bound return Node_Id is 2215 Bound : constant Node_Id := Make_Real_Literal (Loc, Ureal_1); 2216 begin 2217 Set_Etype (Bound, Universal_Real); 2218 return Bound; 2219 end Make_Dummy_Bound; 2220 2221 -- Start of processing for Analyze_Formal_Decimal_Fixed_Point_Type 2222 2223 begin 2224 Enter_Name (T); 2225 2226 Set_Etype (Base, Base); 2227 Set_Size_Info (Base, Int_Base); 2228 Set_RM_Size (Base, RM_Size (Int_Base)); 2229 Set_First_Rep_Item (Base, First_Rep_Item (Int_Base)); 2230 Set_Digits_Value (Base, Digs_Val); 2231 Set_Delta_Value (Base, Delta_Val); 2232 Set_Small_Value (Base, Delta_Val); 2233 Set_Scalar_Range (Base, 2234 Make_Range (Loc, 2235 Low_Bound => Make_Dummy_Bound, 2236 High_Bound => Make_Dummy_Bound)); 2237 2238 Set_Is_Generic_Type (Base); 2239 Set_Parent (Base, Parent (Def)); 2240 2241 Set_Ekind (T, E_Decimal_Fixed_Point_Subtype); 2242 Set_Etype (T, Base); 2243 Set_Size_Info (T, Int_Base); 2244 Set_RM_Size (T, RM_Size (Int_Base)); 2245 Set_First_Rep_Item (T, First_Rep_Item (Int_Base)); 2246 Set_Digits_Value (T, Digs_Val); 2247 Set_Delta_Value (T, Delta_Val); 2248 Set_Small_Value (T, Delta_Val); 2249 Set_Scalar_Range (T, Scalar_Range (Base)); 2250 Set_Is_Constrained (T); 2251 2252 Check_Restriction (No_Fixed_Point, Def); 2253 end Analyze_Formal_Decimal_Fixed_Point_Type; 2254 2255 ------------------------------------------- 2256 -- Analyze_Formal_Derived_Interface_Type -- 2257 ------------------------------------------- 2258 2259 procedure Analyze_Formal_Derived_Interface_Type 2260 (N : Node_Id; 2261 T : Entity_Id; 2262 Def : Node_Id) 2263 is 2264 Loc : constant Source_Ptr := Sloc (Def); 2265 2266 begin 2267 -- Rewrite as a type declaration of a derived type. This ensures that 2268 -- the interface list and primitive operations are properly captured. 2269 2270 Rewrite (N, 2271 Make_Full_Type_Declaration (Loc, 2272 Defining_Identifier => T, 2273 Type_Definition => Def)); 2274 Analyze (N); 2275 Set_Is_Generic_Type (T); 2276 end Analyze_Formal_Derived_Interface_Type; 2277 2278 --------------------------------- 2279 -- Analyze_Formal_Derived_Type -- 2280 --------------------------------- 2281 2282 procedure Analyze_Formal_Derived_Type 2283 (N : Node_Id; 2284 T : Entity_Id; 2285 Def : Node_Id) 2286 is 2287 Loc : constant Source_Ptr := Sloc (Def); 2288 Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N); 2289 New_N : Node_Id; 2290 2291 begin 2292 Set_Is_Generic_Type (T); 2293 2294 if Private_Present (Def) then 2295 New_N := 2296 Make_Private_Extension_Declaration (Loc, 2297 Defining_Identifier => T, 2298 Discriminant_Specifications => Discriminant_Specifications (N), 2299 Unknown_Discriminants_Present => Unk_Disc, 2300 Subtype_Indication => Subtype_Mark (Def), 2301 Interface_List => Interface_List (Def)); 2302 2303 Set_Abstract_Present (New_N, Abstract_Present (Def)); 2304 Set_Limited_Present (New_N, Limited_Present (Def)); 2305 Set_Synchronized_Present (New_N, Synchronized_Present (Def)); 2306 2307 else 2308 New_N := 2309 Make_Full_Type_Declaration (Loc, 2310 Defining_Identifier => T, 2311 Discriminant_Specifications => 2312 Discriminant_Specifications (Parent (T)), 2313 Type_Definition => 2314 Make_Derived_Type_Definition (Loc, 2315 Subtype_Indication => Subtype_Mark (Def))); 2316 2317 Set_Abstract_Present 2318 (Type_Definition (New_N), Abstract_Present (Def)); 2319 Set_Limited_Present 2320 (Type_Definition (New_N), Limited_Present (Def)); 2321 end if; 2322 2323 Rewrite (N, New_N); 2324 Analyze (N); 2325 2326 if Unk_Disc then 2327 if not Is_Composite_Type (T) then 2328 Error_Msg_N 2329 ("unknown discriminants not allowed for elementary types", N); 2330 else 2331 Set_Has_Unknown_Discriminants (T); 2332 Set_Is_Constrained (T, False); 2333 end if; 2334 end if; 2335 2336 -- If the parent type has a known size, so does the formal, which makes 2337 -- legal representation clauses that involve the formal. 2338 2339 Set_Size_Known_At_Compile_Time 2340 (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); 2341 end Analyze_Formal_Derived_Type; 2342 2343 ---------------------------------- 2344 -- Analyze_Formal_Discrete_Type -- 2345 ---------------------------------- 2346 2347 -- The operations defined for a discrete types are those of an enumeration 2348 -- type. The size is set to an arbitrary value, for use in analyzing the 2349 -- generic unit. 2350 2351 procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is 2352 Loc : constant Source_Ptr := Sloc (Def); 2353 Lo : Node_Id; 2354 Hi : Node_Id; 2355 2356 Base : constant Entity_Id := 2357 New_Internal_Entity 2358 (E_Floating_Point_Type, Current_Scope, 2359 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2360 2361 begin 2362 Enter_Name (T); 2363 Set_Ekind (T, E_Enumeration_Subtype); 2364 Set_Etype (T, Base); 2365 Init_Size (T, 8); 2366 Init_Alignment (T); 2367 Set_Is_Generic_Type (T); 2368 Set_Is_Constrained (T); 2369 2370 -- For semantic analysis, the bounds of the type must be set to some 2371 -- non-static value. The simplest is to create attribute nodes for those 2372 -- bounds, that refer to the type itself. These bounds are never 2373 -- analyzed but serve as place-holders. 2374 2375 Lo := 2376 Make_Attribute_Reference (Loc, 2377 Attribute_Name => Name_First, 2378 Prefix => New_Occurrence_Of (T, Loc)); 2379 Set_Etype (Lo, T); 2380 2381 Hi := 2382 Make_Attribute_Reference (Loc, 2383 Attribute_Name => Name_Last, 2384 Prefix => New_Occurrence_Of (T, Loc)); 2385 Set_Etype (Hi, T); 2386 2387 Set_Scalar_Range (T, 2388 Make_Range (Loc, 2389 Low_Bound => Lo, 2390 High_Bound => Hi)); 2391 2392 Set_Ekind (Base, E_Enumeration_Type); 2393 Set_Etype (Base, Base); 2394 Init_Size (Base, 8); 2395 Init_Alignment (Base); 2396 Set_Is_Generic_Type (Base); 2397 Set_Scalar_Range (Base, Scalar_Range (T)); 2398 Set_Parent (Base, Parent (Def)); 2399 end Analyze_Formal_Discrete_Type; 2400 2401 ---------------------------------- 2402 -- Analyze_Formal_Floating_Type -- 2403 --------------------------------- 2404 2405 procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is 2406 Base : constant Entity_Id := 2407 New_Internal_Entity 2408 (E_Floating_Point_Type, Current_Scope, 2409 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2410 2411 begin 2412 -- The various semantic attributes are taken from the predefined type 2413 -- Float, just so that all of them are initialized. Their values are 2414 -- never used because no constant folding or expansion takes place in 2415 -- the generic itself. 2416 2417 Enter_Name (T); 2418 Set_Ekind (T, E_Floating_Point_Subtype); 2419 Set_Etype (T, Base); 2420 Set_Size_Info (T, (Standard_Float)); 2421 Set_RM_Size (T, RM_Size (Standard_Float)); 2422 Set_Digits_Value (T, Digits_Value (Standard_Float)); 2423 Set_Scalar_Range (T, Scalar_Range (Standard_Float)); 2424 Set_Is_Constrained (T); 2425 2426 Set_Is_Generic_Type (Base); 2427 Set_Etype (Base, Base); 2428 Set_Size_Info (Base, (Standard_Float)); 2429 Set_RM_Size (Base, RM_Size (Standard_Float)); 2430 Set_Digits_Value (Base, Digits_Value (Standard_Float)); 2431 Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); 2432 Set_Parent (Base, Parent (Def)); 2433 2434 Check_Restriction (No_Floating_Point, Def); 2435 end Analyze_Formal_Floating_Type; 2436 2437 ----------------------------------- 2438 -- Analyze_Formal_Interface_Type;-- 2439 ----------------------------------- 2440 2441 procedure Analyze_Formal_Interface_Type 2442 (N : Node_Id; 2443 T : Entity_Id; 2444 Def : Node_Id) 2445 is 2446 Loc : constant Source_Ptr := Sloc (N); 2447 New_N : Node_Id; 2448 2449 begin 2450 New_N := 2451 Make_Full_Type_Declaration (Loc, 2452 Defining_Identifier => T, 2453 Type_Definition => Def); 2454 2455 Rewrite (N, New_N); 2456 Analyze (N); 2457 Set_Is_Generic_Type (T); 2458 end Analyze_Formal_Interface_Type; 2459 2460 --------------------------------- 2461 -- Analyze_Formal_Modular_Type -- 2462 --------------------------------- 2463 2464 procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is 2465 begin 2466 -- Apart from their entity kind, generic modular types are treated like 2467 -- signed integer types, and have the same attributes. 2468 2469 Analyze_Formal_Signed_Integer_Type (T, Def); 2470 Set_Ekind (T, E_Modular_Integer_Subtype); 2471 Set_Ekind (Etype (T), E_Modular_Integer_Type); 2472 2473 end Analyze_Formal_Modular_Type; 2474 2475 --------------------------------------- 2476 -- Analyze_Formal_Object_Declaration -- 2477 --------------------------------------- 2478 2479 procedure Analyze_Formal_Object_Declaration (N : Node_Id) is 2480 E : constant Node_Id := Default_Expression (N); 2481 Id : constant Node_Id := Defining_Identifier (N); 2482 K : Entity_Kind; 2483 T : Node_Id; 2484 2485 begin 2486 Enter_Name (Id); 2487 2488 -- Determine the mode of the formal object 2489 2490 if Out_Present (N) then 2491 K := E_Generic_In_Out_Parameter; 2492 2493 if not In_Present (N) then 2494 Error_Msg_N ("formal generic objects cannot have mode OUT", N); 2495 end if; 2496 2497 else 2498 K := E_Generic_In_Parameter; 2499 end if; 2500 2501 if Present (Subtype_Mark (N)) then 2502 Find_Type (Subtype_Mark (N)); 2503 T := Entity (Subtype_Mark (N)); 2504 2505 -- Verify that there is no redundant null exclusion 2506 2507 if Null_Exclusion_Present (N) then 2508 if not Is_Access_Type (T) then 2509 Error_Msg_N 2510 ("null exclusion can only apply to an access type", N); 2511 2512 elsif Can_Never_Be_Null (T) then 2513 Error_Msg_NE 2514 ("`NOT NULL` not allowed (& already excludes null)", N, T); 2515 end if; 2516 end if; 2517 2518 -- Ada 2005 (AI-423): Formal object with an access definition 2519 2520 else 2521 Check_Access_Definition (N); 2522 T := Access_Definition 2523 (Related_Nod => N, 2524 N => Access_Definition (N)); 2525 end if; 2526 2527 if Ekind (T) = E_Incomplete_Type then 2528 declare 2529 Error_Node : Node_Id; 2530 2531 begin 2532 if Present (Subtype_Mark (N)) then 2533 Error_Node := Subtype_Mark (N); 2534 else 2535 Check_Access_Definition (N); 2536 Error_Node := Access_Definition (N); 2537 end if; 2538 2539 Error_Msg_N ("premature usage of incomplete type", Error_Node); 2540 end; 2541 end if; 2542 2543 if K = E_Generic_In_Parameter then 2544 2545 -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals 2546 2547 if Ada_Version < Ada_2005 and then Is_Limited_Type (T) then 2548 Error_Msg_N 2549 ("generic formal of mode IN must not be of limited type", N); 2550 Explain_Limited_Type (T, N); 2551 end if; 2552 2553 if Is_Abstract_Type (T) then 2554 Error_Msg_N 2555 ("generic formal of mode IN must not be of abstract type", N); 2556 end if; 2557 2558 if Present (E) then 2559 Preanalyze_Spec_Expression (E, T); 2560 2561 if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then 2562 Error_Msg_N 2563 ("initialization not allowed for limited types", E); 2564 Explain_Limited_Type (T, E); 2565 end if; 2566 end if; 2567 2568 Set_Ekind (Id, K); 2569 Set_Etype (Id, T); 2570 2571 -- Case of generic IN OUT parameter 2572 2573 else 2574 -- If the formal has an unconstrained type, construct its actual 2575 -- subtype, as is done for subprogram formals. In this fashion, all 2576 -- its uses can refer to specific bounds. 2577 2578 Set_Ekind (Id, K); 2579 Set_Etype (Id, T); 2580 2581 if (Is_Array_Type (T) and then not Is_Constrained (T)) 2582 or else (Ekind (T) = E_Record_Type and then Has_Discriminants (T)) 2583 then 2584 declare 2585 Non_Freezing_Ref : constant Node_Id := 2586 New_Occurrence_Of (Id, Sloc (Id)); 2587 Decl : Node_Id; 2588 2589 begin 2590 -- Make sure the actual subtype doesn't generate bogus freezing 2591 2592 Set_Must_Not_Freeze (Non_Freezing_Ref); 2593 Decl := Build_Actual_Subtype (T, Non_Freezing_Ref); 2594 Insert_Before_And_Analyze (N, Decl); 2595 Set_Actual_Subtype (Id, Defining_Identifier (Decl)); 2596 end; 2597 else 2598 Set_Actual_Subtype (Id, T); 2599 end if; 2600 2601 if Present (E) then 2602 Error_Msg_N 2603 ("initialization not allowed for `IN OUT` formals", N); 2604 end if; 2605 end if; 2606 2607 if Has_Aspects (N) then 2608 Analyze_Aspect_Specifications (N, Id); 2609 end if; 2610 end Analyze_Formal_Object_Declaration; 2611 2612 ---------------------------------------------- 2613 -- Analyze_Formal_Ordinary_Fixed_Point_Type -- 2614 ---------------------------------------------- 2615 2616 procedure Analyze_Formal_Ordinary_Fixed_Point_Type 2617 (T : Entity_Id; 2618 Def : Node_Id) 2619 is 2620 Loc : constant Source_Ptr := Sloc (Def); 2621 Base : constant Entity_Id := 2622 New_Internal_Entity 2623 (E_Ordinary_Fixed_Point_Type, Current_Scope, 2624 Sloc (Defining_Identifier (Parent (Def))), 'G'); 2625 2626 begin 2627 -- The semantic attributes are set for completeness only, their values 2628 -- will never be used, since all properties of the type are non-static. 2629 2630 Enter_Name (T); 2631 Set_Ekind (T, E_Ordinary_Fixed_Point_Subtype); 2632 Set_Etype (T, Base); 2633 Set_Size_Info (T, Standard_Integer); 2634 Set_RM_Size (T, RM_Size (Standard_Integer)); 2635 Set_Small_Value (T, Ureal_1); 2636 Set_Delta_Value (T, Ureal_1); 2637 Set_Scalar_Range (T, 2638 Make_Range (Loc, 2639 Low_Bound => Make_Real_Literal (Loc, Ureal_1), 2640 High_Bound => Make_Real_Literal (Loc, Ureal_1))); 2641 Set_Is_Constrained (T); 2642 2643 Set_Is_Generic_Type (Base); 2644 Set_Etype (Base, Base); 2645 Set_Size_Info (Base, Standard_Integer); 2646 Set_RM_Size (Base, RM_Size (Standard_Integer)); 2647 Set_Small_Value (Base, Ureal_1); 2648 Set_Delta_Value (Base, Ureal_1); 2649 Set_Scalar_Range (Base, Scalar_Range (T)); 2650 Set_Parent (Base, Parent (Def)); 2651 2652 Check_Restriction (No_Fixed_Point, Def); 2653 end Analyze_Formal_Ordinary_Fixed_Point_Type; 2654 2655 ---------------------------------------- 2656 -- Analyze_Formal_Package_Declaration -- 2657 ---------------------------------------- 2658 2659 procedure Analyze_Formal_Package_Declaration (N : Node_Id) is 2660 Gen_Id : constant Node_Id := Name (N); 2661 Loc : constant Source_Ptr := Sloc (N); 2662 Pack_Id : constant Entity_Id := Defining_Identifier (N); 2663 Formal : Entity_Id; 2664 Gen_Decl : Node_Id; 2665 Gen_Unit : Entity_Id; 2666 Renaming : Node_Id; 2667 2668 Vis_Prims_List : Elist_Id := No_Elist; 2669 -- List of primitives made temporarily visible in the instantiation 2670 -- to match the visibility of the formal type. 2671 2672 function Build_Local_Package return Node_Id; 2673 -- The formal package is rewritten so that its parameters are replaced 2674 -- with corresponding declarations. For parameters with bona fide 2675 -- associations these declarations are created by Analyze_Associations 2676 -- as for a regular instantiation. For boxed parameters, we preserve 2677 -- the formal declarations and analyze them, in order to introduce 2678 -- entities of the right kind in the environment of the formal. 2679 2680 ------------------------- 2681 -- Build_Local_Package -- 2682 ------------------------- 2683 2684 function Build_Local_Package return Node_Id is 2685 Decls : List_Id; 2686 Pack_Decl : Node_Id; 2687 2688 begin 2689 -- Within the formal, the name of the generic package is a renaming 2690 -- of the formal (as for a regular instantiation). 2691 2692 Pack_Decl := 2693 Make_Package_Declaration (Loc, 2694 Specification => 2695 Copy_Generic_Node 2696 (Specification (Original_Node (Gen_Decl)), 2697 Empty, Instantiating => True)); 2698 2699 Renaming := 2700 Make_Package_Renaming_Declaration (Loc, 2701 Defining_Unit_Name => 2702 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 2703 Name => New_Occurrence_Of (Formal, Loc)); 2704 2705 if Nkind (Gen_Id) = N_Identifier 2706 and then Chars (Gen_Id) = Chars (Pack_Id) 2707 then 2708 Error_Msg_NE 2709 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 2710 end if; 2711 2712 -- If the formal is declared with a box, or with an others choice, 2713 -- create corresponding declarations for all entities in the formal 2714 -- part, so that names with the proper types are available in the 2715 -- specification of the formal package. 2716 2717 -- On the other hand, if there are no associations, then all the 2718 -- formals must have defaults, and this will be checked by the 2719 -- call to Analyze_Associations. 2720 2721 if Box_Present (N) 2722 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2723 then 2724 declare 2725 Formal_Decl : Node_Id; 2726 2727 begin 2728 -- TBA : for a formal package, need to recurse ??? 2729 2730 Decls := New_List; 2731 Formal_Decl := 2732 First 2733 (Generic_Formal_Declarations (Original_Node (Gen_Decl))); 2734 while Present (Formal_Decl) loop 2735 Append_To 2736 (Decls, 2737 Copy_Generic_Node 2738 (Formal_Decl, Empty, Instantiating => True)); 2739 Next (Formal_Decl); 2740 end loop; 2741 end; 2742 2743 -- If generic associations are present, use Analyze_Associations to 2744 -- create the proper renaming declarations. 2745 2746 else 2747 declare 2748 Act_Tree : constant Node_Id := 2749 Copy_Generic_Node 2750 (Original_Node (Gen_Decl), Empty, 2751 Instantiating => True); 2752 2753 begin 2754 Generic_Renamings.Set_Last (0); 2755 Generic_Renamings_HTable.Reset; 2756 Instantiation_Node := N; 2757 2758 Decls := 2759 Analyze_Associations 2760 (I_Node => Original_Node (N), 2761 Formals => Generic_Formal_Declarations (Act_Tree), 2762 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 2763 2764 Vis_Prims_List := Check_Hidden_Primitives (Decls); 2765 end; 2766 end if; 2767 2768 Append (Renaming, To => Decls); 2769 2770 -- Add generated declarations ahead of local declarations in 2771 -- the package. 2772 2773 if No (Visible_Declarations (Specification (Pack_Decl))) then 2774 Set_Visible_Declarations (Specification (Pack_Decl), Decls); 2775 else 2776 Insert_List_Before 2777 (First (Visible_Declarations (Specification (Pack_Decl))), 2778 Decls); 2779 end if; 2780 2781 return Pack_Decl; 2782 end Build_Local_Package; 2783 2784 -- Local variables 2785 2786 Save_ISMP : constant Boolean := Ignore_SPARK_Mode_Pragmas_In_Instance; 2787 -- Save flag Ignore_SPARK_Mode_Pragmas_In_Instance for restore on exit 2788 2789 Associations : Boolean := True; 2790 New_N : Node_Id; 2791 Parent_Installed : Boolean := False; 2792 Parent_Instance : Entity_Id; 2793 Renaming_In_Par : Entity_Id; 2794 2795 -- Start of processing for Analyze_Formal_Package_Declaration 2796 2797 begin 2798 Check_Text_IO_Special_Unit (Gen_Id); 2799 2800 Init_Env; 2801 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 2802 Gen_Unit := Entity (Gen_Id); 2803 2804 -- Check for a formal package that is a package renaming 2805 2806 if Present (Renamed_Object (Gen_Unit)) then 2807 2808 -- Indicate that unit is used, before replacing it with renamed 2809 -- entity for use below. 2810 2811 if In_Extended_Main_Source_Unit (N) then 2812 Set_Is_Instantiated (Gen_Unit); 2813 Generate_Reference (Gen_Unit, N); 2814 end if; 2815 2816 Gen_Unit := Renamed_Object (Gen_Unit); 2817 end if; 2818 2819 if Ekind (Gen_Unit) /= E_Generic_Package then 2820 Error_Msg_N ("expect generic package name", Gen_Id); 2821 Restore_Env; 2822 goto Leave; 2823 2824 elsif Gen_Unit = Current_Scope then 2825 Error_Msg_N 2826 ("generic package cannot be used as a formal package of itself", 2827 Gen_Id); 2828 Restore_Env; 2829 goto Leave; 2830 2831 elsif In_Open_Scopes (Gen_Unit) then 2832 if Is_Compilation_Unit (Gen_Unit) 2833 and then Is_Child_Unit (Current_Scope) 2834 then 2835 -- Special-case the error when the formal is a parent, and 2836 -- continue analysis to minimize cascaded errors. 2837 2838 Error_Msg_N 2839 ("generic parent cannot be used as formal package of a child " 2840 & "unit", Gen_Id); 2841 2842 else 2843 Error_Msg_N 2844 ("generic package cannot be used as a formal package within " 2845 & "itself", Gen_Id); 2846 Restore_Env; 2847 goto Leave; 2848 end if; 2849 end if; 2850 2851 -- Check that name of formal package does not hide name of generic, 2852 -- or its leading prefix. This check must be done separately because 2853 -- the name of the generic has already been analyzed. 2854 2855 declare 2856 Gen_Name : Entity_Id; 2857 2858 begin 2859 Gen_Name := Gen_Id; 2860 while Nkind (Gen_Name) = N_Expanded_Name loop 2861 Gen_Name := Prefix (Gen_Name); 2862 end loop; 2863 2864 if Chars (Gen_Name) = Chars (Pack_Id) then 2865 Error_Msg_NE 2866 ("& is hidden within declaration of formal package", 2867 Gen_Id, Gen_Name); 2868 end if; 2869 end; 2870 2871 if Box_Present (N) 2872 or else No (Generic_Associations (N)) 2873 or else Nkind (First (Generic_Associations (N))) = N_Others_Choice 2874 then 2875 Associations := False; 2876 end if; 2877 2878 -- If there are no generic associations, the generic parameters appear 2879 -- as local entities and are instantiated like them. We copy the generic 2880 -- package declaration as if it were an instantiation, and analyze it 2881 -- like a regular package, except that we treat the formals as 2882 -- additional visible components. 2883 2884 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 2885 2886 if In_Extended_Main_Source_Unit (N) then 2887 Set_Is_Instantiated (Gen_Unit); 2888 Generate_Reference (Gen_Unit, N); 2889 end if; 2890 2891 Formal := New_Copy (Pack_Id); 2892 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 2893 2894 -- Make local generic without formals. The formals will be replaced with 2895 -- internal declarations. 2896 2897 begin 2898 New_N := Build_Local_Package; 2899 2900 -- If there are errors in the parameter list, Analyze_Associations 2901 -- raises Instantiation_Error. Patch the declaration to prevent further 2902 -- exception propagation. 2903 2904 exception 2905 when Instantiation_Error => 2906 Enter_Name (Formal); 2907 Set_Ekind (Formal, E_Variable); 2908 Set_Etype (Formal, Any_Type); 2909 Restore_Hidden_Primitives (Vis_Prims_List); 2910 2911 if Parent_Installed then 2912 Remove_Parent; 2913 end if; 2914 2915 goto Leave; 2916 end; 2917 2918 Rewrite (N, New_N); 2919 Set_Defining_Unit_Name (Specification (New_N), Formal); 2920 Set_Generic_Parent (Specification (N), Gen_Unit); 2921 Set_Instance_Env (Gen_Unit, Formal); 2922 Set_Is_Generic_Instance (Formal); 2923 2924 Enter_Name (Formal); 2925 Set_Ekind (Formal, E_Package); 2926 Set_Etype (Formal, Standard_Void_Type); 2927 Set_Inner_Instances (Formal, New_Elmt_List); 2928 2929 -- It is unclear that any aspects can apply to a formal package 2930 -- declaration, given that they look like a hidden conformance 2931 -- requirement on the corresponding actual. However, Abstract_State 2932 -- must be treated specially because it generates declarations that 2933 -- must appear before other declarations in the specification and 2934 -- must be analyzed at once. 2935 2936 if Present (Aspect_Specifications (Gen_Decl)) then 2937 if No (Aspect_Specifications (N)) then 2938 Set_Aspect_Specifications (N, New_List); 2939 Set_Has_Aspects (N); 2940 end if; 2941 2942 declare 2943 ASN : Node_Id := First (Aspect_Specifications (Gen_Decl)); 2944 New_A : Node_Id; 2945 2946 begin 2947 while Present (ASN) loop 2948 if Get_Aspect_Id (ASN) = Aspect_Abstract_State then 2949 New_A := 2950 Copy_Generic_Node (ASN, Empty, Instantiating => True); 2951 Set_Entity (New_A, Formal); 2952 Set_Analyzed (New_A, False); 2953 Append (New_A, Aspect_Specifications (N)); 2954 Analyze_Aspect_Specifications (N, Formal); 2955 exit; 2956 end if; 2957 2958 Next (ASN); 2959 end loop; 2960 end; 2961 end if; 2962 2963 Push_Scope (Formal); 2964 2965 -- Manually set the SPARK_Mode from the context because the package 2966 -- declaration is never analyzed. 2967 2968 Set_SPARK_Pragma (Formal, SPARK_Mode_Pragma); 2969 Set_SPARK_Aux_Pragma (Formal, SPARK_Mode_Pragma); 2970 Set_SPARK_Pragma_Inherited (Formal); 2971 Set_SPARK_Aux_Pragma_Inherited (Formal); 2972 2973 if Is_Child_Unit (Gen_Unit) and then Parent_Installed then 2974 2975 -- Similarly, we have to make the name of the formal visible in the 2976 -- parent instance, to resolve properly fully qualified names that 2977 -- may appear in the generic unit. The parent instance has been 2978 -- placed on the scope stack ahead of the current scope. 2979 2980 Parent_Instance := Scope_Stack.Table (Scope_Stack.Last - 1).Entity; 2981 2982 Renaming_In_Par := 2983 Make_Defining_Identifier (Loc, Chars (Gen_Unit)); 2984 Set_Ekind (Renaming_In_Par, E_Package); 2985 Set_Etype (Renaming_In_Par, Standard_Void_Type); 2986 Set_Scope (Renaming_In_Par, Parent_Instance); 2987 Set_Parent (Renaming_In_Par, Parent (Formal)); 2988 Set_Renamed_Object (Renaming_In_Par, Formal); 2989 Append_Entity (Renaming_In_Par, Parent_Instance); 2990 end if; 2991 2992 -- A formal package declaration behaves as a package instantiation with 2993 -- respect to SPARK_Mode "off". If the annotation is "off" or altogether 2994 -- missing, set the global flag which signals Analyze_Pragma to ingnore 2995 -- all SPARK_Mode pragmas within the generic_package_name. 2996 2997 if SPARK_Mode /= On then 2998 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 2999 3000 -- Mark the formal spec in case the body is instantiated at a later 3001 -- pass. This preserves the original context in effect for the body. 3002 3003 Set_Ignore_SPARK_Mode_Pragmas (Formal); 3004 end if; 3005 3006 Analyze (Specification (N)); 3007 3008 -- The formals for which associations are provided are not visible 3009 -- outside of the formal package. The others are still declared by a 3010 -- formal parameter declaration. 3011 3012 -- If there are no associations, the only local entity to hide is the 3013 -- generated package renaming itself. 3014 3015 declare 3016 E : Entity_Id; 3017 3018 begin 3019 E := First_Entity (Formal); 3020 while Present (E) loop 3021 if Associations and then not Is_Generic_Formal (E) then 3022 Set_Is_Hidden (E); 3023 end if; 3024 3025 if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then 3026 Set_Is_Hidden (E); 3027 exit; 3028 end if; 3029 3030 Next_Entity (E); 3031 end loop; 3032 end; 3033 3034 End_Package_Scope (Formal); 3035 Restore_Hidden_Primitives (Vis_Prims_List); 3036 3037 if Parent_Installed then 3038 Remove_Parent; 3039 end if; 3040 3041 Restore_Env; 3042 3043 -- Inside the generic unit, the formal package is a regular package, but 3044 -- no body is needed for it. Note that after instantiation, the defining 3045 -- unit name we need is in the new tree and not in the original (see 3046 -- Package_Instantiation). A generic formal package is an instance, and 3047 -- can be used as an actual for an inner instance. 3048 3049 Set_Has_Completion (Formal, True); 3050 3051 -- Add semantic information to the original defining identifier for ASIS 3052 -- use. 3053 3054 Set_Ekind (Pack_Id, E_Package); 3055 Set_Etype (Pack_Id, Standard_Void_Type); 3056 Set_Scope (Pack_Id, Scope (Formal)); 3057 Set_Has_Completion (Pack_Id, True); 3058 3059 <<Leave>> 3060 if Has_Aspects (N) then 3061 -- Unclear that any other aspects may appear here, snalyze them 3062 -- for completion, given that the grammar allows their appearance. 3063 3064 Analyze_Aspect_Specifications (N, Pack_Id); 3065 end if; 3066 3067 Ignore_SPARK_Mode_Pragmas_In_Instance := Save_ISMP; 3068 end Analyze_Formal_Package_Declaration; 3069 3070 --------------------------------- 3071 -- Analyze_Formal_Private_Type -- 3072 --------------------------------- 3073 3074 procedure Analyze_Formal_Private_Type 3075 (N : Node_Id; 3076 T : Entity_Id; 3077 Def : Node_Id) 3078 is 3079 begin 3080 New_Private_Type (N, T, Def); 3081 3082 -- Set the size to an arbitrary but legal value 3083 3084 Set_Size_Info (T, Standard_Integer); 3085 Set_RM_Size (T, RM_Size (Standard_Integer)); 3086 end Analyze_Formal_Private_Type; 3087 3088 ------------------------------------ 3089 -- Analyze_Formal_Incomplete_Type -- 3090 ------------------------------------ 3091 3092 procedure Analyze_Formal_Incomplete_Type 3093 (T : Entity_Id; 3094 Def : Node_Id) 3095 is 3096 begin 3097 Enter_Name (T); 3098 Set_Ekind (T, E_Incomplete_Type); 3099 Set_Etype (T, T); 3100 Set_Private_Dependents (T, New_Elmt_List); 3101 3102 if Tagged_Present (Def) then 3103 Set_Is_Tagged_Type (T); 3104 Make_Class_Wide_Type (T); 3105 Set_Direct_Primitive_Operations (T, New_Elmt_List); 3106 end if; 3107 end Analyze_Formal_Incomplete_Type; 3108 3109 ---------------------------------------- 3110 -- Analyze_Formal_Signed_Integer_Type -- 3111 ---------------------------------------- 3112 3113 procedure Analyze_Formal_Signed_Integer_Type 3114 (T : Entity_Id; 3115 Def : Node_Id) 3116 is 3117 Base : constant Entity_Id := 3118 New_Internal_Entity 3119 (E_Signed_Integer_Type, 3120 Current_Scope, 3121 Sloc (Defining_Identifier (Parent (Def))), 'G'); 3122 3123 begin 3124 Enter_Name (T); 3125 3126 Set_Ekind (T, E_Signed_Integer_Subtype); 3127 Set_Etype (T, Base); 3128 Set_Size_Info (T, Standard_Integer); 3129 Set_RM_Size (T, RM_Size (Standard_Integer)); 3130 Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); 3131 Set_Is_Constrained (T); 3132 3133 Set_Is_Generic_Type (Base); 3134 Set_Size_Info (Base, Standard_Integer); 3135 Set_RM_Size (Base, RM_Size (Standard_Integer)); 3136 Set_Etype (Base, Base); 3137 Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); 3138 Set_Parent (Base, Parent (Def)); 3139 end Analyze_Formal_Signed_Integer_Type; 3140 3141 ------------------------------------------- 3142 -- Analyze_Formal_Subprogram_Declaration -- 3143 ------------------------------------------- 3144 3145 procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id) is 3146 Spec : constant Node_Id := Specification (N); 3147 Def : constant Node_Id := Default_Name (N); 3148 Nam : constant Entity_Id := Defining_Unit_Name (Spec); 3149 Subp : Entity_Id; 3150 3151 begin 3152 if Nam = Error then 3153 return; 3154 end if; 3155 3156 if Nkind (Nam) = N_Defining_Program_Unit_Name then 3157 Error_Msg_N ("name of formal subprogram must be a direct name", Nam); 3158 goto Leave; 3159 end if; 3160 3161 Analyze_Subprogram_Declaration (N); 3162 Set_Is_Formal_Subprogram (Nam); 3163 Set_Has_Completion (Nam); 3164 3165 if Nkind (N) = N_Formal_Abstract_Subprogram_Declaration then 3166 Set_Is_Abstract_Subprogram (Nam); 3167 3168 Set_Is_Dispatching_Operation (Nam); 3169 3170 -- A formal abstract procedure cannot have a null default 3171 -- (RM 12.6(4.1/2)). 3172 3173 if Nkind (Spec) = N_Procedure_Specification 3174 and then Null_Present (Spec) 3175 then 3176 Error_Msg_N 3177 ("a formal abstract subprogram cannot default to null", Spec); 3178 end if; 3179 3180 declare 3181 Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam); 3182 begin 3183 if No (Ctrl_Type) then 3184 Error_Msg_N 3185 ("abstract formal subprogram must have a controlling type", 3186 N); 3187 3188 elsif Ada_Version >= Ada_2012 3189 and then Is_Incomplete_Type (Ctrl_Type) 3190 then 3191 Error_Msg_NE 3192 ("controlling type of abstract formal subprogram cannot " 3193 & "be incomplete type", N, Ctrl_Type); 3194 3195 else 3196 Check_Controlling_Formals (Ctrl_Type, Nam); 3197 end if; 3198 end; 3199 end if; 3200 3201 -- Default name is resolved at the point of instantiation 3202 3203 if Box_Present (N) then 3204 null; 3205 3206 -- Else default is bound at the point of generic declaration 3207 3208 elsif Present (Def) then 3209 if Nkind (Def) = N_Operator_Symbol then 3210 Find_Direct_Name (Def); 3211 3212 elsif Nkind (Def) /= N_Attribute_Reference then 3213 Analyze (Def); 3214 3215 else 3216 -- For an attribute reference, analyze the prefix and verify 3217 -- that it has the proper profile for the subprogram. 3218 3219 Analyze (Prefix (Def)); 3220 Valid_Default_Attribute (Nam, Def); 3221 goto Leave; 3222 end if; 3223 3224 -- Default name may be overloaded, in which case the interpretation 3225 -- with the correct profile must be selected, as for a renaming. 3226 -- If the definition is an indexed component, it must denote a 3227 -- member of an entry family. If it is a selected component, it 3228 -- can be a protected operation. 3229 3230 if Etype (Def) = Any_Type then 3231 goto Leave; 3232 3233 elsif Nkind (Def) = N_Selected_Component then 3234 if not Is_Overloadable (Entity (Selector_Name (Def))) then 3235 Error_Msg_N ("expect valid subprogram name as default", Def); 3236 end if; 3237 3238 elsif Nkind (Def) = N_Indexed_Component then 3239 if Is_Entity_Name (Prefix (Def)) then 3240 if Ekind (Entity (Prefix (Def))) /= E_Entry_Family then 3241 Error_Msg_N ("expect valid subprogram name as default", Def); 3242 end if; 3243 3244 elsif Nkind (Prefix (Def)) = N_Selected_Component then 3245 if Ekind (Entity (Selector_Name (Prefix (Def)))) /= 3246 E_Entry_Family 3247 then 3248 Error_Msg_N ("expect valid subprogram name as default", Def); 3249 end if; 3250 3251 else 3252 Error_Msg_N ("expect valid subprogram name as default", Def); 3253 goto Leave; 3254 end if; 3255 3256 elsif Nkind (Def) = N_Character_Literal then 3257 3258 -- Needs some type checks: subprogram should be parameterless??? 3259 3260 Resolve (Def, (Etype (Nam))); 3261 3262 elsif not Is_Entity_Name (Def) 3263 or else not Is_Overloadable (Entity (Def)) 3264 then 3265 Error_Msg_N ("expect valid subprogram name as default", Def); 3266 goto Leave; 3267 3268 elsif not Is_Overloaded (Def) then 3269 Subp := Entity (Def); 3270 3271 if Subp = Nam then 3272 Error_Msg_N ("premature usage of formal subprogram", Def); 3273 3274 elsif not Entity_Matches_Spec (Subp, Nam) then 3275 Error_Msg_N ("no visible entity matches specification", Def); 3276 end if; 3277 3278 -- More than one interpretation, so disambiguate as for a renaming 3279 3280 else 3281 declare 3282 I : Interp_Index; 3283 I1 : Interp_Index := 0; 3284 It : Interp; 3285 It1 : Interp; 3286 3287 begin 3288 Subp := Any_Id; 3289 Get_First_Interp (Def, I, It); 3290 while Present (It.Nam) loop 3291 if Entity_Matches_Spec (It.Nam, Nam) then 3292 if Subp /= Any_Id then 3293 It1 := Disambiguate (Def, I1, I, Etype (Subp)); 3294 3295 if It1 = No_Interp then 3296 Error_Msg_N ("ambiguous default subprogram", Def); 3297 else 3298 Subp := It1.Nam; 3299 end if; 3300 3301 exit; 3302 3303 else 3304 I1 := I; 3305 Subp := It.Nam; 3306 end if; 3307 end if; 3308 3309 Get_Next_Interp (I, It); 3310 end loop; 3311 end; 3312 3313 if Subp /= Any_Id then 3314 3315 -- Subprogram found, generate reference to it 3316 3317 Set_Entity (Def, Subp); 3318 Generate_Reference (Subp, Def); 3319 3320 if Subp = Nam then 3321 Error_Msg_N ("premature usage of formal subprogram", Def); 3322 3323 elsif Ekind (Subp) /= E_Operator then 3324 Check_Mode_Conformant (Subp, Nam); 3325 end if; 3326 3327 else 3328 Error_Msg_N ("no visible subprogram matches specification", N); 3329 end if; 3330 end if; 3331 end if; 3332 3333 <<Leave>> 3334 if Has_Aspects (N) then 3335 Analyze_Aspect_Specifications (N, Nam); 3336 end if; 3337 3338 end Analyze_Formal_Subprogram_Declaration; 3339 3340 ------------------------------------- 3341 -- Analyze_Formal_Type_Declaration -- 3342 ------------------------------------- 3343 3344 procedure Analyze_Formal_Type_Declaration (N : Node_Id) is 3345 Def : constant Node_Id := Formal_Type_Definition (N); 3346 T : Entity_Id; 3347 3348 begin 3349 T := Defining_Identifier (N); 3350 3351 if Present (Discriminant_Specifications (N)) 3352 and then Nkind (Def) /= N_Formal_Private_Type_Definition 3353 then 3354 Error_Msg_N 3355 ("discriminants not allowed for this formal type", T); 3356 end if; 3357 3358 -- Enter the new name, and branch to specific routine 3359 3360 case Nkind (Def) is 3361 when N_Formal_Private_Type_Definition => 3362 Analyze_Formal_Private_Type (N, T, Def); 3363 3364 when N_Formal_Derived_Type_Definition => 3365 Analyze_Formal_Derived_Type (N, T, Def); 3366 3367 when N_Formal_Incomplete_Type_Definition => 3368 Analyze_Formal_Incomplete_Type (T, Def); 3369 3370 when N_Formal_Discrete_Type_Definition => 3371 Analyze_Formal_Discrete_Type (T, Def); 3372 3373 when N_Formal_Signed_Integer_Type_Definition => 3374 Analyze_Formal_Signed_Integer_Type (T, Def); 3375 3376 when N_Formal_Modular_Type_Definition => 3377 Analyze_Formal_Modular_Type (T, Def); 3378 3379 when N_Formal_Floating_Point_Definition => 3380 Analyze_Formal_Floating_Type (T, Def); 3381 3382 when N_Formal_Ordinary_Fixed_Point_Definition => 3383 Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); 3384 3385 when N_Formal_Decimal_Fixed_Point_Definition => 3386 Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); 3387 3388 when N_Array_Type_Definition => 3389 Analyze_Formal_Array_Type (T, Def); 3390 3391 when N_Access_Function_Definition 3392 | N_Access_Procedure_Definition 3393 | N_Access_To_Object_Definition 3394 => 3395 Analyze_Generic_Access_Type (T, Def); 3396 3397 -- Ada 2005: a interface declaration is encoded as an abstract 3398 -- record declaration or a abstract type derivation. 3399 3400 when N_Record_Definition => 3401 Analyze_Formal_Interface_Type (N, T, Def); 3402 3403 when N_Derived_Type_Definition => 3404 Analyze_Formal_Derived_Interface_Type (N, T, Def); 3405 3406 when N_Error => 3407 null; 3408 3409 when others => 3410 raise Program_Error; 3411 end case; 3412 3413 -- A formal type declaration declares a type and its first 3414 -- subtype. 3415 3416 Set_Is_Generic_Type (T); 3417 Set_Is_First_Subtype (T); 3418 3419 if Has_Aspects (N) then 3420 Analyze_Aspect_Specifications (N, T); 3421 end if; 3422 end Analyze_Formal_Type_Declaration; 3423 3424 ------------------------------------ 3425 -- Analyze_Function_Instantiation -- 3426 ------------------------------------ 3427 3428 procedure Analyze_Function_Instantiation (N : Node_Id) is 3429 begin 3430 Analyze_Subprogram_Instantiation (N, E_Function); 3431 end Analyze_Function_Instantiation; 3432 3433 --------------------------------- 3434 -- Analyze_Generic_Access_Type -- 3435 --------------------------------- 3436 3437 procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is 3438 begin 3439 Enter_Name (T); 3440 3441 if Nkind (Def) = N_Access_To_Object_Definition then 3442 Access_Type_Declaration (T, Def); 3443 3444 if Is_Incomplete_Or_Private_Type (Designated_Type (T)) 3445 and then No (Full_View (Designated_Type (T))) 3446 and then not Is_Generic_Type (Designated_Type (T)) 3447 then 3448 Error_Msg_N ("premature usage of incomplete type", Def); 3449 3450 elsif not Is_Entity_Name (Subtype_Indication (Def)) then 3451 Error_Msg_N 3452 ("only a subtype mark is allowed in a formal", Def); 3453 end if; 3454 3455 else 3456 Access_Subprogram_Declaration (T, Def); 3457 end if; 3458 end Analyze_Generic_Access_Type; 3459 3460 --------------------------------- 3461 -- Analyze_Generic_Formal_Part -- 3462 --------------------------------- 3463 3464 procedure Analyze_Generic_Formal_Part (N : Node_Id) is 3465 Gen_Parm_Decl : Node_Id; 3466 3467 begin 3468 -- The generic formals are processed in the scope of the generic unit, 3469 -- where they are immediately visible. The scope is installed by the 3470 -- caller. 3471 3472 Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); 3473 while Present (Gen_Parm_Decl) loop 3474 Analyze (Gen_Parm_Decl); 3475 Next (Gen_Parm_Decl); 3476 end loop; 3477 3478 Generate_Reference_To_Generic_Formals (Current_Scope); 3479 end Analyze_Generic_Formal_Part; 3480 3481 ------------------------------------------ 3482 -- Analyze_Generic_Package_Declaration -- 3483 ------------------------------------------ 3484 3485 procedure Analyze_Generic_Package_Declaration (N : Node_Id) is 3486 Decls : constant List_Id := Visible_Declarations (Specification (N)); 3487 Loc : constant Source_Ptr := Sloc (N); 3488 3489 Decl : Node_Id; 3490 Id : Entity_Id; 3491 New_N : Node_Id; 3492 Renaming : Node_Id; 3493 Save_Parent : Node_Id; 3494 3495 begin 3496 Check_SPARK_05_Restriction ("generic is not allowed", N); 3497 3498 -- A generic may grant access to its private enclosing context depending 3499 -- on the placement of its corresponding body. From elaboration point of 3500 -- view, the flow of execution may enter this private context, and then 3501 -- reach an external unit, thus producing a dependency on that external 3502 -- unit. For such a path to be properly discovered and encoded in the 3503 -- ALI file of the main unit, let the ABE mechanism process the body of 3504 -- the main unit, and encode all relevant invocation constructs and the 3505 -- relations between them. 3506 3507 Mark_Save_Invocation_Graph_Of_Body; 3508 3509 -- We introduce a renaming of the enclosing package, to have a usable 3510 -- entity as the prefix of an expanded name for a local entity of the 3511 -- form Par.P.Q, where P is the generic package. This is because a local 3512 -- entity named P may hide it, so that the usual visibility rules in 3513 -- the instance will not resolve properly. 3514 3515 Renaming := 3516 Make_Package_Renaming_Declaration (Loc, 3517 Defining_Unit_Name => 3518 Make_Defining_Identifier (Loc, 3519 Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")), 3520 Name => 3521 Make_Identifier (Loc, Chars (Defining_Entity (N)))); 3522 3523 -- The declaration is inserted before other declarations, but before 3524 -- pragmas that may be library-unit pragmas and must appear before other 3525 -- declarations. The pragma Compile_Time_Error is not in this class, and 3526 -- may contain an expression that includes such a qualified name, so the 3527 -- renaming declaration must appear before it. 3528 3529 -- Are there other pragmas that require this special handling ??? 3530 3531 if Present (Decls) then 3532 Decl := First (Decls); 3533 while Present (Decl) 3534 and then Nkind (Decl) = N_Pragma 3535 and then Get_Pragma_Id (Decl) /= Pragma_Compile_Time_Error 3536 loop 3537 Next (Decl); 3538 end loop; 3539 3540 if Present (Decl) then 3541 Insert_Before (Decl, Renaming); 3542 else 3543 Append (Renaming, Visible_Declarations (Specification (N))); 3544 end if; 3545 3546 else 3547 Set_Visible_Declarations (Specification (N), New_List (Renaming)); 3548 end if; 3549 3550 -- Create copy of generic unit, and save for instantiation. If the unit 3551 -- is a child unit, do not copy the specifications for the parent, which 3552 -- are not part of the generic tree. 3553 3554 Save_Parent := Parent_Spec (N); 3555 Set_Parent_Spec (N, Empty); 3556 3557 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3558 Set_Parent_Spec (New_N, Save_Parent); 3559 Rewrite (N, New_N); 3560 3561 -- Once the contents of the generic copy and the template are swapped, 3562 -- do the same for their respective aspect specifications. 3563 3564 Exchange_Aspects (N, New_N); 3565 3566 -- Collect all contract-related source pragmas found within the template 3567 -- and attach them to the contract of the package spec. This contract is 3568 -- used in the capture of global references within annotations. 3569 3570 Create_Generic_Contract (N); 3571 3572 Id := Defining_Entity (N); 3573 Generate_Definition (Id); 3574 3575 -- Expansion is not applied to generic units 3576 3577 Start_Generic; 3578 3579 Enter_Name (Id); 3580 Set_Ekind (Id, E_Generic_Package); 3581 Set_Etype (Id, Standard_Void_Type); 3582 3583 -- Set SPARK_Mode from context 3584 3585 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3586 Set_SPARK_Aux_Pragma (Id, SPARK_Mode_Pragma); 3587 Set_SPARK_Pragma_Inherited (Id); 3588 Set_SPARK_Aux_Pragma_Inherited (Id); 3589 3590 -- Preserve relevant elaboration-related attributes of the context which 3591 -- are no longer available or very expensive to recompute once analysis, 3592 -- resolution, and expansion are over. 3593 3594 Mark_Elaboration_Attributes 3595 (N_Id => Id, 3596 Checks => True, 3597 Warnings => True); 3598 3599 -- Analyze aspects now, so that generated pragmas appear in the 3600 -- declarations before building and analyzing the generic copy. 3601 3602 if Has_Aspects (N) then 3603 Analyze_Aspect_Specifications (N, Id); 3604 end if; 3605 3606 Push_Scope (Id); 3607 Enter_Generic_Scope (Id); 3608 Set_Inner_Instances (Id, New_Elmt_List); 3609 3610 Set_Categorization_From_Pragmas (N); 3611 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3612 3613 -- Link the declaration of the generic homonym in the generic copy to 3614 -- the package it renames, so that it is always resolved properly. 3615 3616 Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming)); 3617 Set_Entity (Associated_Node (Name (Renaming)), Id); 3618 3619 -- For a library unit, we have reconstructed the entity for the unit, 3620 -- and must reset it in the library tables. 3621 3622 if Nkind (Parent (N)) = N_Compilation_Unit then 3623 Set_Cunit_Entity (Current_Sem_Unit, Id); 3624 end if; 3625 3626 Analyze_Generic_Formal_Part (N); 3627 3628 -- After processing the generic formals, analysis proceeds as for a 3629 -- non-generic package. 3630 3631 Analyze (Specification (N)); 3632 3633 Validate_Categorization_Dependency (N, Id); 3634 3635 End_Generic; 3636 3637 End_Package_Scope (Id); 3638 Exit_Generic_Scope (Id); 3639 3640 -- If the generic appears within a package unit, the body of that unit 3641 -- has to be present for instantiation and inlining. 3642 3643 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration then 3644 Set_Body_Needed_For_Inlining 3645 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3646 end if; 3647 3648 if Nkind (Parent (N)) /= N_Compilation_Unit then 3649 Move_Freeze_Nodes (Id, N, Visible_Declarations (Specification (N))); 3650 Move_Freeze_Nodes (Id, N, Private_Declarations (Specification (N))); 3651 Move_Freeze_Nodes (Id, N, Generic_Formal_Declarations (N)); 3652 3653 else 3654 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3655 Validate_RT_RAT_Component (N); 3656 3657 -- If this is a spec without a body, check that generic parameters 3658 -- are referenced. 3659 3660 if not Body_Required (Parent (N)) then 3661 Check_References (Id); 3662 end if; 3663 end if; 3664 3665 -- If there is a specified storage pool in the context, create an 3666 -- aspect on the package declaration, so that it is used in any 3667 -- instance that does not override it. 3668 3669 if Present (Default_Pool) then 3670 declare 3671 ASN : Node_Id; 3672 3673 begin 3674 ASN := 3675 Make_Aspect_Specification (Loc, 3676 Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), 3677 Expression => New_Copy (Default_Pool)); 3678 3679 if No (Aspect_Specifications (Specification (N))) then 3680 Set_Aspect_Specifications (Specification (N), New_List (ASN)); 3681 else 3682 Append (ASN, Aspect_Specifications (Specification (N))); 3683 end if; 3684 end; 3685 end if; 3686 end Analyze_Generic_Package_Declaration; 3687 3688 -------------------------------------------- 3689 -- Analyze_Generic_Subprogram_Declaration -- 3690 -------------------------------------------- 3691 3692 procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is 3693 Formals : List_Id; 3694 Id : Entity_Id; 3695 New_N : Node_Id; 3696 Result_Type : Entity_Id; 3697 Save_Parent : Node_Id; 3698 Spec : Node_Id; 3699 Typ : Entity_Id; 3700 3701 begin 3702 Check_SPARK_05_Restriction ("generic is not allowed", N); 3703 3704 -- A generic may grant access to its private enclosing context depending 3705 -- on the placement of its corresponding body. From elaboration point of 3706 -- view, the flow of execution may enter this private context, and then 3707 -- reach an external unit, thus producing a dependency on that external 3708 -- unit. For such a path to be properly discovered and encoded in the 3709 -- ALI file of the main unit, let the ABE mechanism process the body of 3710 -- the main unit, and encode all relevant invocation constructs and the 3711 -- relations between them. 3712 3713 Mark_Save_Invocation_Graph_Of_Body; 3714 3715 -- Create copy of generic unit, and save for instantiation. If the unit 3716 -- is a child unit, do not copy the specifications for the parent, which 3717 -- are not part of the generic tree. 3718 3719 Save_Parent := Parent_Spec (N); 3720 Set_Parent_Spec (N, Empty); 3721 3722 New_N := Copy_Generic_Node (N, Empty, Instantiating => False); 3723 Set_Parent_Spec (New_N, Save_Parent); 3724 Rewrite (N, New_N); 3725 3726 -- Once the contents of the generic copy and the template are swapped, 3727 -- do the same for their respective aspect specifications. 3728 3729 Exchange_Aspects (N, New_N); 3730 3731 -- Collect all contract-related source pragmas found within the template 3732 -- and attach them to the contract of the subprogram spec. This contract 3733 -- is used in the capture of global references within annotations. 3734 3735 Create_Generic_Contract (N); 3736 3737 Spec := Specification (N); 3738 Id := Defining_Entity (Spec); 3739 Generate_Definition (Id); 3740 3741 if Nkind (Id) = N_Defining_Operator_Symbol then 3742 Error_Msg_N 3743 ("operator symbol not allowed for generic subprogram", Id); 3744 end if; 3745 3746 Start_Generic; 3747 3748 Enter_Name (Id); 3749 Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); 3750 3751 -- Analyze the aspects of the generic copy to ensure that all generated 3752 -- pragmas (if any) perform their semantic effects. 3753 3754 if Has_Aspects (N) then 3755 Analyze_Aspect_Specifications (N, Id); 3756 end if; 3757 3758 Push_Scope (Id); 3759 Enter_Generic_Scope (Id); 3760 Set_Inner_Instances (Id, New_Elmt_List); 3761 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 3762 3763 Analyze_Generic_Formal_Part (N); 3764 3765 if Nkind (Spec) = N_Function_Specification then 3766 Set_Ekind (Id, E_Generic_Function); 3767 else 3768 Set_Ekind (Id, E_Generic_Procedure); 3769 end if; 3770 3771 -- Set SPARK_Mode from context 3772 3773 Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); 3774 Set_SPARK_Pragma_Inherited (Id); 3775 3776 -- Preserve relevant elaboration-related attributes of the context which 3777 -- are no longer available or very expensive to recompute once analysis, 3778 -- resolution, and expansion are over. 3779 3780 Mark_Elaboration_Attributes 3781 (N_Id => Id, 3782 Checks => True, 3783 Warnings => True); 3784 3785 Formals := Parameter_Specifications (Spec); 3786 3787 if Present (Formals) then 3788 Process_Formals (Formals, Spec); 3789 end if; 3790 3791 if Nkind (Spec) = N_Function_Specification then 3792 if Nkind (Result_Definition (Spec)) = N_Access_Definition then 3793 Result_Type := Access_Definition (Spec, Result_Definition (Spec)); 3794 Set_Etype (Id, Result_Type); 3795 3796 -- Check restriction imposed by AI05-073: a generic function 3797 -- cannot return an abstract type or an access to such. 3798 3799 -- This is a binding interpretation should it apply to earlier 3800 -- versions of Ada as well as Ada 2012??? 3801 3802 if Is_Abstract_Type (Designated_Type (Result_Type)) 3803 and then Ada_Version >= Ada_2012 3804 then 3805 Error_Msg_N 3806 ("generic function cannot have an access result " 3807 & "that designates an abstract type", Spec); 3808 end if; 3809 3810 else 3811 Find_Type (Result_Definition (Spec)); 3812 Typ := Entity (Result_Definition (Spec)); 3813 3814 if Is_Abstract_Type (Typ) 3815 and then Ada_Version >= Ada_2012 3816 then 3817 Error_Msg_N 3818 ("generic function cannot have abstract result type", Spec); 3819 end if; 3820 3821 -- If a null exclusion is imposed on the result type, then create 3822 -- a null-excluding itype (an access subtype) and use it as the 3823 -- function's Etype. 3824 3825 if Is_Access_Type (Typ) 3826 and then Null_Exclusion_Present (Spec) 3827 then 3828 Set_Etype (Id, 3829 Create_Null_Excluding_Itype 3830 (T => Typ, 3831 Related_Nod => Spec, 3832 Scope_Id => Defining_Unit_Name (Spec))); 3833 else 3834 Set_Etype (Id, Typ); 3835 end if; 3836 end if; 3837 3838 else 3839 Set_Etype (Id, Standard_Void_Type); 3840 end if; 3841 3842 -- For a library unit, we have reconstructed the entity for the unit, 3843 -- and must reset it in the library tables. We also make sure that 3844 -- Body_Required is set properly in the original compilation unit node. 3845 3846 if Nkind (Parent (N)) = N_Compilation_Unit then 3847 Set_Cunit_Entity (Current_Sem_Unit, Id); 3848 Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); 3849 end if; 3850 3851 -- If the generic appears within a package unit, the body of that unit 3852 -- has to be present for instantiation and inlining. 3853 3854 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 3855 and then Unit_Requires_Body (Id) 3856 then 3857 Set_Body_Needed_For_Inlining 3858 (Defining_Entity (Unit (Cunit (Current_Sem_Unit)))); 3859 end if; 3860 3861 Set_Categorization_From_Pragmas (N); 3862 Validate_Categorization_Dependency (N, Id); 3863 3864 -- Capture all global references that occur within the profile of the 3865 -- generic subprogram. Aspects are not part of this processing because 3866 -- they must be delayed. If processed now, Save_Global_References will 3867 -- destroy the Associated_Node links and prevent the capture of global 3868 -- references when the contract of the generic subprogram is analyzed. 3869 3870 Save_Global_References (Original_Node (N)); 3871 3872 End_Generic; 3873 End_Scope; 3874 Exit_Generic_Scope (Id); 3875 Generate_Reference_To_Formals (Id); 3876 3877 List_Inherited_Pre_Post_Aspects (Id); 3878 end Analyze_Generic_Subprogram_Declaration; 3879 3880 ----------------------------------- 3881 -- Analyze_Package_Instantiation -- 3882 ----------------------------------- 3883 3884 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 3885 -- must be replaced by gotos which jump to the end of the routine in order 3886 -- to restore the Ghost and SPARK modes. 3887 3888 procedure Analyze_Package_Instantiation (N : Node_Id) is 3889 Has_Inline_Always : Boolean := False; 3890 -- Set if the generic unit contains any subprograms with Inline_Always. 3891 -- Only relevant when back-end inlining is not enabled. 3892 3893 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean; 3894 -- Return True if inlining is active and Gen_Unit contains inlined 3895 -- subprograms. In this case, we may either instantiate the body when 3896 -- front-end inlining is enabled, or add a pending instantiation when 3897 -- back-end inlining is enabled. In the former case, this may cause 3898 -- superfluous instantiations, but in either case we need to perform 3899 -- the instantiation of the body in the context of the instance and 3900 -- not in that of the point of inlining. 3901 3902 function Needs_Body_Instantiated (Gen_Unit : Entity_Id) return Boolean; 3903 -- Return True if Gen_Unit needs to have its body instantiated in the 3904 -- context of N. This in particular excludes generic contexts. 3905 3906 ----------------------- 3907 -- Might_Inline_Subp -- 3908 ----------------------- 3909 3910 function Might_Inline_Subp (Gen_Unit : Entity_Id) return Boolean is 3911 E : Entity_Id; 3912 3913 begin 3914 if Inline_Processing_Required then 3915 -- No need to recompute the answer if we know it is positive 3916 -- and back-end inlining is enabled. 3917 3918 if Is_Inlined (Gen_Unit) and then Back_End_Inlining then 3919 return True; 3920 end if; 3921 3922 E := First_Entity (Gen_Unit); 3923 while Present (E) loop 3924 if Is_Subprogram (E) and then Is_Inlined (E) then 3925 -- Remember if there are any subprograms with Inline_Always 3926 3927 if Has_Pragma_Inline_Always (E) then 3928 Has_Inline_Always := True; 3929 end if; 3930 3931 Set_Is_Inlined (Gen_Unit); 3932 return True; 3933 end if; 3934 3935 Next_Entity (E); 3936 end loop; 3937 end if; 3938 3939 return False; 3940 end Might_Inline_Subp; 3941 3942 ------------------------------- 3943 -- Needs_Body_Instantiated -- 3944 ------------------------------- 3945 3946 function Needs_Body_Instantiated (Gen_Unit : Entity_Id) return Boolean is 3947 begin 3948 -- No need to instantiate bodies in generic units 3949 3950 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then 3951 return False; 3952 end if; 3953 3954 -- If the instantiation is in the main unit, then the body is needed 3955 3956 if Is_In_Main_Unit (N) then 3957 return True; 3958 end if; 3959 3960 -- If not, then again no need to instantiate bodies in generic units 3961 3962 if Is_Generic_Unit (Cunit_Entity (Get_Code_Unit (N))) then 3963 return False; 3964 end if; 3965 3966 -- Here we have a special handling for back-end inlining: if inline 3967 -- processing is required, then we unconditionally want to have the 3968 -- body instantiated. The reason is that Might_Inline_Subp does not 3969 -- catch all the cases (as it does not recurse into nested packages) 3970 -- so this avoids the need to patch things up afterwards. Moreover, 3971 -- these instantiations are only performed on demand when back-end 3972 -- inlining is enabled, so this causes very little extra work. 3973 3974 if Inline_Processing_Required and then Back_End_Inlining then 3975 return True; 3976 end if; 3977 3978 -- We want to have the bodies instantiated in non-main units if 3979 -- they might contribute inlined subprograms. 3980 3981 return Might_Inline_Subp (Gen_Unit); 3982 end Needs_Body_Instantiated; 3983 3984 -- Local declarations 3985 3986 Gen_Id : constant Node_Id := Name (N); 3987 Inst_Id : constant Entity_Id := Defining_Entity (N); 3988 Is_Actual_Pack : constant Boolean := Is_Internal (Inst_Id); 3989 Loc : constant Source_Ptr := Sloc (N); 3990 3991 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 3992 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 3993 Saved_ISMP : constant Boolean := 3994 Ignore_SPARK_Mode_Pragmas_In_Instance; 3995 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 3996 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 3997 -- Save the Ghost and SPARK mode-related data to restore on exit 3998 3999 Saved_Style_Check : constant Boolean := Style_Check; 4000 -- Save style check mode for restore on exit 4001 4002 Act_Decl : Node_Id; 4003 Act_Decl_Name : Node_Id; 4004 Act_Decl_Id : Entity_Id; 4005 Act_Spec : Node_Id; 4006 Act_Tree : Node_Id; 4007 Env_Installed : Boolean := False; 4008 Gen_Decl : Node_Id; 4009 Gen_Spec : Node_Id; 4010 Gen_Unit : Entity_Id; 4011 Inline_Now : Boolean := False; 4012 Needs_Body : Boolean; 4013 Parent_Installed : Boolean := False; 4014 Renaming_List : List_Id; 4015 Unit_Renaming : Node_Id; 4016 4017 Vis_Prims_List : Elist_Id := No_Elist; 4018 -- List of primitives made temporarily visible in the instantiation 4019 -- to match the visibility of the formal type 4020 4021 -- Start of processing for Analyze_Package_Instantiation 4022 4023 begin 4024 -- Preserve relevant elaboration-related attributes of the context which 4025 -- are no longer available or very expensive to recompute once analysis, 4026 -- resolution, and expansion are over. 4027 4028 Mark_Elaboration_Attributes 4029 (N_Id => N, 4030 Checks => True, 4031 Level => True, 4032 Modes => True, 4033 Warnings => True); 4034 4035 Check_SPARK_05_Restriction ("generic is not allowed", N); 4036 4037 -- Very first thing: check for Text_IO special unit in case we are 4038 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. 4039 4040 Check_Text_IO_Special_Unit (Name (N)); 4041 4042 -- Make node global for error reporting 4043 4044 Instantiation_Node := N; 4045 4046 -- Case of instantiation of a generic package 4047 4048 if Nkind (N) = N_Package_Instantiation then 4049 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4050 Set_Comes_From_Source (Act_Decl_Id, True); 4051 4052 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then 4053 Act_Decl_Name := 4054 Make_Defining_Program_Unit_Name (Loc, 4055 Name => 4056 New_Copy_Tree (Name (Defining_Unit_Name (N))), 4057 Defining_Identifier => Act_Decl_Id); 4058 else 4059 Act_Decl_Name := Act_Decl_Id; 4060 end if; 4061 4062 -- Case of instantiation of a formal package 4063 4064 else 4065 Act_Decl_Id := Defining_Identifier (N); 4066 Act_Decl_Name := Act_Decl_Id; 4067 end if; 4068 4069 Generate_Definition (Act_Decl_Id); 4070 Set_Ekind (Act_Decl_Id, E_Package); 4071 4072 -- Initialize list of incomplete actuals before analysis 4073 4074 Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List); 4075 4076 Preanalyze_Actuals (N, Act_Decl_Id); 4077 4078 -- Turn off style checking in instances. If the check is enabled on the 4079 -- generic unit, a warning in an instance would just be noise. If not 4080 -- enabled on the generic, then a warning in an instance is just wrong. 4081 -- This must be done after analyzing the actuals, which do come from 4082 -- source and are subject to style checking. 4083 4084 Style_Check := False; 4085 4086 Init_Env; 4087 Env_Installed := True; 4088 4089 -- Reset renaming map for formal types. The mapping is established 4090 -- when analyzing the generic associations, but some mappings are 4091 -- inherited from formal packages of parent units, and these are 4092 -- constructed when the parents are installed. 4093 4094 Generic_Renamings.Set_Last (0); 4095 Generic_Renamings_HTable.Reset; 4096 4097 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 4098 Gen_Unit := Entity (Gen_Id); 4099 4100 -- A package instantiation is Ghost when it is subject to pragma Ghost 4101 -- or the generic template is Ghost. Set the mode now to ensure that 4102 -- any nodes generated during analysis and expansion are marked as 4103 -- Ghost. 4104 4105 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 4106 4107 -- Verify that it is the name of a generic package 4108 4109 -- A visibility glitch: if the instance is a child unit and the generic 4110 -- is the generic unit of a parent instance (i.e. both the parent and 4111 -- the child units are instances of the same package) the name now 4112 -- denotes the renaming within the parent, not the intended generic 4113 -- unit. See if there is a homonym that is the desired generic. The 4114 -- renaming declaration must be visible inside the instance of the 4115 -- child, but not when analyzing the name in the instantiation itself. 4116 4117 if Ekind (Gen_Unit) = E_Package 4118 and then Present (Renamed_Entity (Gen_Unit)) 4119 and then In_Open_Scopes (Renamed_Entity (Gen_Unit)) 4120 and then Is_Generic_Instance (Renamed_Entity (Gen_Unit)) 4121 and then Present (Homonym (Gen_Unit)) 4122 then 4123 Gen_Unit := Homonym (Gen_Unit); 4124 end if; 4125 4126 if Etype (Gen_Unit) = Any_Type then 4127 Restore_Env; 4128 goto Leave; 4129 4130 elsif Ekind (Gen_Unit) /= E_Generic_Package then 4131 4132 -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause 4133 4134 if From_Limited_With (Gen_Unit) then 4135 Error_Msg_N 4136 ("cannot instantiate a limited withed package", Gen_Id); 4137 else 4138 Error_Msg_NE 4139 ("& is not the name of a generic package", Gen_Id, Gen_Unit); 4140 end if; 4141 4142 Restore_Env; 4143 goto Leave; 4144 end if; 4145 4146 if In_Extended_Main_Source_Unit (N) then 4147 Set_Is_Instantiated (Gen_Unit); 4148 Generate_Reference (Gen_Unit, N); 4149 4150 if Present (Renamed_Object (Gen_Unit)) then 4151 Set_Is_Instantiated (Renamed_Object (Gen_Unit)); 4152 Generate_Reference (Renamed_Object (Gen_Unit), N); 4153 end if; 4154 end if; 4155 4156 if Nkind (Gen_Id) = N_Identifier 4157 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 4158 then 4159 Error_Msg_NE 4160 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 4161 4162 elsif Nkind (Gen_Id) = N_Expanded_Name 4163 and then Is_Child_Unit (Gen_Unit) 4164 and then Nkind (Prefix (Gen_Id)) = N_Identifier 4165 and then Chars (Act_Decl_Id) = Chars (Prefix (Gen_Id)) 4166 then 4167 Error_Msg_N 4168 ("& is hidden within declaration of instance ", Prefix (Gen_Id)); 4169 end if; 4170 4171 Set_Entity (Gen_Id, Gen_Unit); 4172 4173 -- If generic is a renaming, get original generic unit 4174 4175 if Present (Renamed_Object (Gen_Unit)) 4176 and then Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Package 4177 then 4178 Gen_Unit := Renamed_Object (Gen_Unit); 4179 end if; 4180 4181 -- Verify that there are no circular instantiations 4182 4183 if In_Open_Scopes (Gen_Unit) then 4184 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 4185 Restore_Env; 4186 goto Leave; 4187 4188 elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 4189 Error_Msg_Node_2 := Current_Scope; 4190 Error_Msg_NE 4191 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 4192 Circularity_Detected := True; 4193 Restore_Env; 4194 goto Leave; 4195 4196 else 4197 Set_Ekind (Inst_Id, E_Package); 4198 Set_Scope (Inst_Id, Current_Scope); 4199 4200 -- If the context of the instance is subject to SPARK_Mode "off" or 4201 -- the annotation is altogether missing, set the global flag which 4202 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 4203 -- the instance. 4204 4205 if SPARK_Mode /= On then 4206 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 4207 4208 -- Mark the instance spec in case the body is instantiated at a 4209 -- later pass. This preserves the original context in effect for 4210 -- the body. 4211 4212 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 4213 end if; 4214 4215 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 4216 Gen_Spec := Specification (Gen_Decl); 4217 4218 -- Initialize renamings map, for error checking, and the list that 4219 -- holds private entities whose views have changed between generic 4220 -- definition and instantiation. If this is the instance created to 4221 -- validate an actual package, the instantiation environment is that 4222 -- of the enclosing instance. 4223 4224 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 4225 4226 -- Copy original generic tree, to produce text for instantiation 4227 4228 Act_Tree := 4229 Copy_Generic_Node 4230 (Original_Node (Gen_Decl), Empty, Instantiating => True); 4231 4232 Act_Spec := Specification (Act_Tree); 4233 4234 -- If this is the instance created to validate an actual package, 4235 -- only the formals matter, do not examine the package spec itself. 4236 4237 if Is_Actual_Pack then 4238 Set_Visible_Declarations (Act_Spec, New_List); 4239 Set_Private_Declarations (Act_Spec, New_List); 4240 end if; 4241 4242 Renaming_List := 4243 Analyze_Associations 4244 (I_Node => N, 4245 Formals => Generic_Formal_Declarations (Act_Tree), 4246 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 4247 4248 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 4249 4250 Set_Instance_Env (Gen_Unit, Act_Decl_Id); 4251 Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); 4252 Set_Is_Generic_Instance (Act_Decl_Id); 4253 Set_Generic_Parent (Act_Spec, Gen_Unit); 4254 4255 -- References to the generic in its own declaration or its body are 4256 -- references to the instance. Add a renaming declaration for the 4257 -- generic unit itself. This declaration, as well as the renaming 4258 -- declarations for the generic formals, must remain private to the 4259 -- unit: the formals, because this is the language semantics, and 4260 -- the unit because its use is an artifact of the implementation. 4261 4262 Unit_Renaming := 4263 Make_Package_Renaming_Declaration (Loc, 4264 Defining_Unit_Name => 4265 Make_Defining_Identifier (Loc, Chars (Gen_Unit)), 4266 Name => New_Occurrence_Of (Act_Decl_Id, Loc)); 4267 4268 Append (Unit_Renaming, Renaming_List); 4269 4270 -- The renaming declarations are the first local declarations of the 4271 -- new unit. 4272 4273 if Is_Non_Empty_List (Visible_Declarations (Act_Spec)) then 4274 Insert_List_Before 4275 (First (Visible_Declarations (Act_Spec)), Renaming_List); 4276 else 4277 Set_Visible_Declarations (Act_Spec, Renaming_List); 4278 end if; 4279 4280 Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); 4281 4282 -- Propagate the aspect specifications from the package declaration 4283 -- template to the instantiated version of the package declaration. 4284 4285 if Has_Aspects (Act_Tree) then 4286 Set_Aspect_Specifications (Act_Decl, 4287 New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); 4288 end if; 4289 4290 -- The generic may have a generated Default_Storage_Pool aspect, 4291 -- set at the point of generic declaration. If the instance has 4292 -- that aspect, it overrides the one inherited from the generic. 4293 4294 if Has_Aspects (Gen_Spec) then 4295 if No (Aspect_Specifications (N)) then 4296 Set_Aspect_Specifications (N, 4297 (New_Copy_List_Tree 4298 (Aspect_Specifications (Gen_Spec)))); 4299 4300 else 4301 declare 4302 Inherited_Aspects : constant List_Id := 4303 New_Copy_List_Tree 4304 (Aspect_Specifications (Gen_Spec)); 4305 4306 ASN1 : Node_Id; 4307 ASN2 : Node_Id; 4308 Pool_Present : Boolean := False; 4309 4310 begin 4311 ASN1 := First (Aspect_Specifications (N)); 4312 while Present (ASN1) loop 4313 if Chars (Identifier (ASN1)) = 4314 Name_Default_Storage_Pool 4315 then 4316 Pool_Present := True; 4317 exit; 4318 end if; 4319 4320 Next (ASN1); 4321 end loop; 4322 4323 if Pool_Present then 4324 4325 -- If generic carries a default storage pool, remove it 4326 -- in favor of the instance one. 4327 4328 ASN2 := First (Inherited_Aspects); 4329 while Present (ASN2) loop 4330 if Chars (Identifier (ASN2)) = 4331 Name_Default_Storage_Pool 4332 then 4333 Remove (ASN2); 4334 exit; 4335 end if; 4336 4337 Next (ASN2); 4338 end loop; 4339 end if; 4340 4341 Prepend_List_To 4342 (Aspect_Specifications (N), Inherited_Aspects); 4343 end; 4344 end if; 4345 end if; 4346 4347 -- Save the instantiation node for a subsequent instantiation of the 4348 -- body if there is one and it needs to be instantiated here. 4349 4350 -- We instantiate the body only if we are generating code, or if we 4351 -- are generating cross-reference information, or if we are building 4352 -- trees for ASIS use or GNATprove use. 4353 4354 declare 4355 Enclosing_Body_Present : Boolean := False; 4356 -- If the generic unit is not a compilation unit, then a body may 4357 -- be present in its parent even if none is required. We create a 4358 -- tentative pending instantiation for the body, which will be 4359 -- discarded if none is actually present. 4360 4361 Scop : Entity_Id; 4362 4363 begin 4364 if Scope (Gen_Unit) /= Standard_Standard 4365 and then not Is_Child_Unit (Gen_Unit) 4366 then 4367 Scop := Scope (Gen_Unit); 4368 while Present (Scop) and then Scop /= Standard_Standard loop 4369 if Unit_Requires_Body (Scop) then 4370 Enclosing_Body_Present := True; 4371 exit; 4372 4373 elsif In_Open_Scopes (Scop) 4374 and then In_Package_Body (Scop) 4375 then 4376 Enclosing_Body_Present := True; 4377 exit; 4378 end if; 4379 4380 exit when Is_Compilation_Unit (Scop); 4381 Scop := Scope (Scop); 4382 end loop; 4383 end if; 4384 4385 -- If front-end inlining is enabled or there are any subprograms 4386 -- marked with Inline_Always, and this is a unit for which code 4387 -- will be generated, we instantiate the body at once. 4388 4389 -- This is done if the instance is not the main unit, and if the 4390 -- generic is not a child unit of another generic, to avoid scope 4391 -- problems and the reinstallation of parent instances. 4392 4393 if Expander_Active 4394 and then (not Is_Child_Unit (Gen_Unit) 4395 or else not Is_Generic_Unit (Scope (Gen_Unit))) 4396 and then Might_Inline_Subp (Gen_Unit) 4397 and then not Is_Actual_Pack 4398 then 4399 if not Back_End_Inlining 4400 and then (Front_End_Inlining or else Has_Inline_Always) 4401 and then (Is_In_Main_Unit (N) 4402 or else In_Main_Context (Current_Scope)) 4403 and then Nkind (Parent (N)) /= N_Compilation_Unit 4404 then 4405 Inline_Now := True; 4406 4407 -- In configurable_run_time mode we force the inlining of 4408 -- predefined subprograms marked Inline_Always, to minimize 4409 -- the use of the run-time library. 4410 4411 elsif In_Predefined_Unit (Gen_Decl) 4412 and then Configurable_Run_Time_Mode 4413 and then Nkind (Parent (N)) /= N_Compilation_Unit 4414 then 4415 Inline_Now := True; 4416 end if; 4417 4418 -- If the current scope is itself an instance within a child 4419 -- unit, there will be duplications in the scope stack, and the 4420 -- unstacking mechanism in Inline_Instance_Body will fail. 4421 -- This loses some rare cases of optimization, and might be 4422 -- improved some day, if we can find a proper abstraction for 4423 -- "the complete compilation context" that can be saved and 4424 -- restored. ??? 4425 4426 if Is_Generic_Instance (Current_Scope) then 4427 declare 4428 Curr_Unit : constant Entity_Id := 4429 Cunit_Entity (Current_Sem_Unit); 4430 begin 4431 if Curr_Unit /= Current_Scope 4432 and then Is_Child_Unit (Curr_Unit) 4433 then 4434 Inline_Now := False; 4435 end if; 4436 end; 4437 end if; 4438 end if; 4439 4440 Needs_Body := 4441 (Unit_Requires_Body (Gen_Unit) 4442 or else Enclosing_Body_Present 4443 or else Present (Corresponding_Body (Gen_Decl))) 4444 and then Needs_Body_Instantiated (Gen_Unit) 4445 and then not Is_Actual_Pack 4446 and then not Inline_Now 4447 and then (Operating_Mode = Generate_Code 4448 or else (Operating_Mode = Check_Semantics 4449 and then (ASIS_Mode or GNATprove_Mode))); 4450 4451 -- If front-end inlining is enabled or there are any subprograms 4452 -- marked with Inline_Always, do not instantiate body when within 4453 -- a generic context. 4454 4455 if not Back_End_Inlining 4456 and then (Front_End_Inlining or else Has_Inline_Always) 4457 and then not Expander_Active 4458 then 4459 Needs_Body := False; 4460 end if; 4461 4462 -- If the current context is generic, and the package being 4463 -- instantiated is declared within a formal package, there is no 4464 -- body to instantiate until the enclosing generic is instantiated 4465 -- and there is an actual for the formal package. If the formal 4466 -- package has parameters, we build a regular package instance for 4467 -- it, that precedes the original formal package declaration. 4468 4469 if In_Open_Scopes (Scope (Scope (Gen_Unit))) then 4470 declare 4471 Decl : constant Node_Id := 4472 Original_Node 4473 (Unit_Declaration_Node (Scope (Gen_Unit))); 4474 begin 4475 if Nkind (Decl) = N_Formal_Package_Declaration 4476 or else (Nkind (Decl) = N_Package_Declaration 4477 and then Is_List_Member (Decl) 4478 and then Present (Next (Decl)) 4479 and then 4480 Nkind (Next (Decl)) = 4481 N_Formal_Package_Declaration) 4482 then 4483 Needs_Body := False; 4484 end if; 4485 end; 4486 end if; 4487 end; 4488 4489 -- For RCI unit calling stubs, we omit the instance body if the 4490 -- instance is the RCI library unit itself. 4491 4492 -- However there is a special case for nested instances: in this case 4493 -- we do generate the instance body, as it might be required, e.g. 4494 -- because it provides stream attributes for some type used in the 4495 -- profile of a remote subprogram. This is consistent with 12.3(12), 4496 -- which indicates that the instance body occurs at the place of the 4497 -- instantiation, and thus is part of the RCI declaration, which is 4498 -- present on all client partitions (this is E.2.3(18)). 4499 4500 -- Note that AI12-0002 may make it illegal at some point to have 4501 -- stream attributes defined in an RCI unit, in which case this 4502 -- special case will become unnecessary. In the meantime, there 4503 -- is known application code in production that depends on this 4504 -- being possible, so we definitely cannot eliminate the body in 4505 -- the case of nested instances for the time being. 4506 4507 -- When we generate a nested instance body, calling stubs for any 4508 -- relevant subprogram will be inserted immediately after the 4509 -- subprogram declarations, and will take precedence over the 4510 -- subsequent (original) body. (The stub and original body will be 4511 -- complete homographs, but this is permitted in an instance). 4512 -- (Could we do better and remove the original body???) 4513 4514 if Distribution_Stub_Mode = Generate_Caller_Stub_Body 4515 and then Comes_From_Source (N) 4516 and then Nkind (Parent (N)) = N_Compilation_Unit 4517 then 4518 Needs_Body := False; 4519 end if; 4520 4521 if Needs_Body then 4522 -- Indicate that the enclosing scopes contain an instantiation, 4523 -- and that cleanup actions should be delayed until after the 4524 -- instance body is expanded. 4525 4526 Check_Forward_Instantiation (Gen_Decl); 4527 if Nkind (N) = N_Package_Instantiation then 4528 declare 4529 Enclosing_Master : Entity_Id; 4530 4531 begin 4532 -- Loop to search enclosing masters 4533 4534 Enclosing_Master := Current_Scope; 4535 Scope_Loop : while Enclosing_Master /= Standard_Standard loop 4536 if Ekind (Enclosing_Master) = E_Package then 4537 if Is_Compilation_Unit (Enclosing_Master) then 4538 if In_Package_Body (Enclosing_Master) then 4539 Set_Delay_Subprogram_Descriptors 4540 (Body_Entity (Enclosing_Master)); 4541 else 4542 Set_Delay_Subprogram_Descriptors 4543 (Enclosing_Master); 4544 end if; 4545 4546 exit Scope_Loop; 4547 4548 else 4549 Enclosing_Master := Scope (Enclosing_Master); 4550 end if; 4551 4552 elsif Is_Generic_Unit (Enclosing_Master) 4553 or else Ekind (Enclosing_Master) = E_Void 4554 then 4555 -- Cleanup actions will eventually be performed on the 4556 -- enclosing subprogram or package instance, if any. 4557 -- Enclosing scope is void in the formal part of a 4558 -- generic subprogram. 4559 4560 exit Scope_Loop; 4561 4562 else 4563 if Ekind (Enclosing_Master) = E_Entry 4564 and then 4565 Ekind (Scope (Enclosing_Master)) = E_Protected_Type 4566 then 4567 if not Expander_Active then 4568 exit Scope_Loop; 4569 else 4570 Enclosing_Master := 4571 Protected_Body_Subprogram (Enclosing_Master); 4572 end if; 4573 end if; 4574 4575 Set_Delay_Cleanups (Enclosing_Master); 4576 4577 while Ekind (Enclosing_Master) = E_Block loop 4578 Enclosing_Master := Scope (Enclosing_Master); 4579 end loop; 4580 4581 if Is_Subprogram (Enclosing_Master) then 4582 Set_Delay_Subprogram_Descriptors (Enclosing_Master); 4583 4584 elsif Is_Task_Type (Enclosing_Master) then 4585 declare 4586 TBP : constant Node_Id := 4587 Get_Task_Body_Procedure 4588 (Enclosing_Master); 4589 begin 4590 if Present (TBP) then 4591 Set_Delay_Subprogram_Descriptors (TBP); 4592 Set_Delay_Cleanups (TBP); 4593 end if; 4594 end; 4595 end if; 4596 4597 exit Scope_Loop; 4598 end if; 4599 end loop Scope_Loop; 4600 end; 4601 4602 -- Make entry in table 4603 4604 Add_Pending_Instantiation (N, Act_Decl); 4605 end if; 4606 end if; 4607 4608 Set_Categorization_From_Pragmas (Act_Decl); 4609 4610 if Parent_Installed then 4611 Hide_Current_Scope; 4612 end if; 4613 4614 Set_Instance_Spec (N, Act_Decl); 4615 4616 -- If not a compilation unit, insert the package declaration before 4617 -- the original instantiation node. 4618 4619 if Nkind (Parent (N)) /= N_Compilation_Unit then 4620 Mark_Rewrite_Insertion (Act_Decl); 4621 Insert_Before (N, Act_Decl); 4622 4623 if Has_Aspects (N) then 4624 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4625 4626 -- The pragma created for a Default_Storage_Pool aspect must 4627 -- appear ahead of the declarations in the instance spec. 4628 -- Analysis has placed it after the instance node, so remove 4629 -- it and reinsert it properly now. 4630 4631 declare 4632 ASN : constant Node_Id := First (Aspect_Specifications (N)); 4633 A_Name : constant Name_Id := Chars (Identifier (ASN)); 4634 Decl : Node_Id; 4635 4636 begin 4637 if A_Name = Name_Default_Storage_Pool then 4638 if No (Visible_Declarations (Act_Spec)) then 4639 Set_Visible_Declarations (Act_Spec, New_List); 4640 end if; 4641 4642 Decl := Next (N); 4643 while Present (Decl) loop 4644 if Nkind (Decl) = N_Pragma then 4645 Remove (Decl); 4646 Prepend (Decl, Visible_Declarations (Act_Spec)); 4647 exit; 4648 end if; 4649 4650 Next (Decl); 4651 end loop; 4652 end if; 4653 end; 4654 end if; 4655 4656 Analyze (Act_Decl); 4657 4658 -- For an instantiation that is a compilation unit, place 4659 -- declaration on current node so context is complete for analysis 4660 -- (including nested instantiations). If this is the main unit, 4661 -- the declaration eventually replaces the instantiation node. 4662 -- If the instance body is created later, it replaces the 4663 -- instance node, and the declaration is attached to it 4664 -- (see Build_Instance_Compilation_Unit_Nodes). 4665 4666 else 4667 if Cunit_Entity (Current_Sem_Unit) = Defining_Entity (N) then 4668 4669 -- The entity for the current unit is the newly created one, 4670 -- and all semantic information is attached to it. 4671 4672 Set_Cunit_Entity (Current_Sem_Unit, Act_Decl_Id); 4673 4674 -- If this is the main unit, replace the main entity as well 4675 4676 if Current_Sem_Unit = Main_Unit then 4677 Main_Unit_Entity := Act_Decl_Id; 4678 end if; 4679 end if; 4680 4681 Set_Unit (Parent (N), Act_Decl); 4682 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 4683 Set_Package_Instantiation (Act_Decl_Id, N); 4684 4685 -- Process aspect specifications of the instance node, if any, to 4686 -- take into account categorization pragmas before analyzing the 4687 -- instance. 4688 4689 if Has_Aspects (N) then 4690 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4691 end if; 4692 4693 Analyze (Act_Decl); 4694 Set_Unit (Parent (N), N); 4695 Set_Body_Required (Parent (N), False); 4696 4697 -- We never need elaboration checks on instantiations, since by 4698 -- definition, the body instantiation is elaborated at the same 4699 -- time as the spec instantiation. 4700 4701 if Legacy_Elaboration_Checks then 4702 Set_Kill_Elaboration_Checks (Act_Decl_Id); 4703 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 4704 end if; 4705 end if; 4706 4707 if Legacy_Elaboration_Checks then 4708 Check_Elab_Instantiation (N); 4709 end if; 4710 4711 -- Save the scenario for later examination by the ABE Processing 4712 -- phase. 4713 4714 Record_Elaboration_Scenario (N); 4715 4716 -- The instantiation results in a guaranteed ABE 4717 4718 if Is_Known_Guaranteed_ABE (N) and then Needs_Body then 4719 -- Do not instantiate the corresponding body because gigi cannot 4720 -- handle certain types of premature instantiations. 4721 4722 Remove_Dead_Instance (N); 4723 4724 -- Create completing bodies for all subprogram declarations since 4725 -- their real bodies will not be instantiated. 4726 4727 Provide_Completing_Bodies (Instance_Spec (N)); 4728 end if; 4729 4730 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 4731 4732 Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), 4733 First_Private_Entity (Act_Decl_Id)); 4734 4735 -- If the instantiation will receive a body, the unit will be 4736 -- transformed into a package body, and receive its own elaboration 4737 -- entity. Otherwise, the nature of the unit is now a package 4738 -- declaration. 4739 4740 if Nkind (Parent (N)) = N_Compilation_Unit 4741 and then not Needs_Body 4742 then 4743 Rewrite (N, Act_Decl); 4744 end if; 4745 4746 if Present (Corresponding_Body (Gen_Decl)) 4747 or else Unit_Requires_Body (Gen_Unit) 4748 then 4749 Set_Has_Completion (Act_Decl_Id); 4750 end if; 4751 4752 Check_Formal_Packages (Act_Decl_Id); 4753 4754 Restore_Hidden_Primitives (Vis_Prims_List); 4755 Restore_Private_Views (Act_Decl_Id); 4756 4757 Inherit_Context (Gen_Decl, N); 4758 4759 if Parent_Installed then 4760 Remove_Parent; 4761 end if; 4762 4763 Restore_Env; 4764 Env_Installed := False; 4765 end if; 4766 4767 Validate_Categorization_Dependency (N, Act_Decl_Id); 4768 4769 -- There used to be a check here to prevent instantiations in local 4770 -- contexts if the No_Local_Allocators restriction was active. This 4771 -- check was removed by a binding interpretation in AI-95-00130/07, 4772 -- but we retain the code for documentation purposes. 4773 4774 -- if Ekind (Act_Decl_Id) /= E_Void 4775 -- and then not Is_Library_Level_Entity (Act_Decl_Id) 4776 -- then 4777 -- Check_Restriction (No_Local_Allocators, N); 4778 -- end if; 4779 4780 if Inline_Now then 4781 Inline_Instance_Body (N, Gen_Unit, Act_Decl); 4782 end if; 4783 4784 -- The following is a tree patch for ASIS: ASIS needs separate nodes to 4785 -- be used as defining identifiers for a formal package and for the 4786 -- corresponding expanded package. 4787 4788 if Nkind (N) = N_Formal_Package_Declaration then 4789 Act_Decl_Id := New_Copy (Defining_Entity (N)); 4790 Set_Comes_From_Source (Act_Decl_Id, True); 4791 Set_Is_Generic_Instance (Act_Decl_Id, False); 4792 Set_Defining_Identifier (N, Act_Decl_Id); 4793 end if; 4794 4795 -- Check that if N is an instantiation of System.Dim_Float_IO or 4796 -- System.Dim_Integer_IO, the formal type has a dimension system. 4797 4798 if Nkind (N) = N_Package_Instantiation 4799 and then Is_Dim_IO_Package_Instantiation (N) 4800 then 4801 declare 4802 Assoc : constant Node_Id := First (Generic_Associations (N)); 4803 begin 4804 if not Has_Dimension_System 4805 (Etype (Explicit_Generic_Actual_Parameter (Assoc))) 4806 then 4807 Error_Msg_N ("type with a dimension system expected", Assoc); 4808 end if; 4809 end; 4810 end if; 4811 4812 <<Leave>> 4813 if Has_Aspects (N) and then Nkind (Parent (N)) /= N_Compilation_Unit then 4814 Analyze_Aspect_Specifications (N, Act_Decl_Id); 4815 end if; 4816 4817 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4818 Restore_Ghost_Region (Saved_GM, Saved_IGR); 4819 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4820 Style_Check := Saved_Style_Check; 4821 4822 exception 4823 when Instantiation_Error => 4824 if Parent_Installed then 4825 Remove_Parent; 4826 end if; 4827 4828 if Env_Installed then 4829 Restore_Env; 4830 end if; 4831 4832 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 4833 Restore_Ghost_Region (Saved_GM, Saved_IGR); 4834 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 4835 Style_Check := Saved_Style_Check; 4836 end Analyze_Package_Instantiation; 4837 4838 -------------------------- 4839 -- Inline_Instance_Body -- 4840 -------------------------- 4841 4842 -- WARNING: This routine manages SPARK regions. Return statements must be 4843 -- replaced by gotos which jump to the end of the routine and restore the 4844 -- SPARK mode. 4845 4846 procedure Inline_Instance_Body 4847 (N : Node_Id; 4848 Gen_Unit : Entity_Id; 4849 Act_Decl : Node_Id) 4850 is 4851 Config_Attrs : constant Config_Switches_Type := Save_Config_Switches; 4852 4853 Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); 4854 Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 4855 Gen_Comp : constant Entity_Id := 4856 Cunit_Entity (Get_Source_Unit (Gen_Unit)); 4857 4858 Scope_Stack_Depth : constant Pos := 4859 Scope_Stack.Last - Scope_Stack.First + 1; 4860 4861 Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id; 4862 Instances : array (1 .. Scope_Stack_Depth) of Entity_Id; 4863 Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id; 4864 4865 Curr_Scope : Entity_Id := Empty; 4866 List : Elist_Id := No_Elist; -- init to avoid warning 4867 N_Instances : Nat := 0; 4868 Num_Inner : Nat := 0; 4869 Num_Scopes : Nat := 0; 4870 Removed : Boolean := False; 4871 S : Entity_Id; 4872 Vis : Boolean; 4873 4874 begin 4875 -- Case of generic unit defined in another unit. We must remove the 4876 -- complete context of the current unit to install that of the generic. 4877 4878 if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then 4879 4880 -- Add some comments for the following two loops ??? 4881 4882 S := Current_Scope; 4883 while Present (S) and then S /= Standard_Standard loop 4884 loop 4885 Num_Scopes := Num_Scopes + 1; 4886 4887 Use_Clauses (Num_Scopes) := 4888 (Scope_Stack.Table 4889 (Scope_Stack.Last - Num_Scopes + 1). 4890 First_Use_Clause); 4891 End_Use_Clauses (Use_Clauses (Num_Scopes)); 4892 4893 exit when Scope_Stack.Last - Num_Scopes + 1 = Scope_Stack.First 4894 or else Scope_Stack.Table 4895 (Scope_Stack.Last - Num_Scopes).Entity = Scope (S); 4896 end loop; 4897 4898 exit when Is_Generic_Instance (S) 4899 and then (In_Package_Body (S) 4900 or else Ekind (S) = E_Procedure 4901 or else Ekind (S) = E_Function); 4902 S := Scope (S); 4903 end loop; 4904 4905 Vis := Is_Immediately_Visible (Gen_Comp); 4906 4907 -- Find and save all enclosing instances 4908 4909 S := Current_Scope; 4910 4911 while Present (S) 4912 and then S /= Standard_Standard 4913 loop 4914 if Is_Generic_Instance (S) then 4915 N_Instances := N_Instances + 1; 4916 Instances (N_Instances) := S; 4917 4918 exit when In_Package_Body (S); 4919 end if; 4920 4921 S := Scope (S); 4922 end loop; 4923 4924 -- Remove context of current compilation unit, unless we are within a 4925 -- nested package instantiation, in which case the context has been 4926 -- removed previously. 4927 4928 -- If current scope is the body of a child unit, remove context of 4929 -- spec as well. If an enclosing scope is an instance body, the 4930 -- context has already been removed, but the entities in the body 4931 -- must be made invisible as well. 4932 4933 S := Current_Scope; 4934 while Present (S) and then S /= Standard_Standard loop 4935 if Is_Generic_Instance (S) 4936 and then (In_Package_Body (S) 4937 or else Ekind_In (S, E_Procedure, E_Function)) 4938 then 4939 -- We still have to remove the entities of the enclosing 4940 -- instance from direct visibility. 4941 4942 declare 4943 E : Entity_Id; 4944 begin 4945 E := First_Entity (S); 4946 while Present (E) loop 4947 Set_Is_Immediately_Visible (E, False); 4948 Next_Entity (E); 4949 end loop; 4950 end; 4951 4952 exit; 4953 end if; 4954 4955 if S = Curr_Unit 4956 or else (Ekind (Curr_Unit) = E_Package_Body 4957 and then S = Spec_Entity (Curr_Unit)) 4958 or else (Ekind (Curr_Unit) = E_Subprogram_Body 4959 and then S = Corresponding_Spec 4960 (Unit_Declaration_Node (Curr_Unit))) 4961 then 4962 Removed := True; 4963 4964 -- Remove entities in current scopes from visibility, so that 4965 -- instance body is compiled in a clean environment. 4966 4967 List := Save_Scope_Stack (Handle_Use => False); 4968 4969 if Is_Child_Unit (S) then 4970 4971 -- Remove child unit from stack, as well as inner scopes. 4972 -- Removing the context of a child unit removes parent units 4973 -- as well. 4974 4975 while Current_Scope /= S loop 4976 Num_Inner := Num_Inner + 1; 4977 Inner_Scopes (Num_Inner) := Current_Scope; 4978 Pop_Scope; 4979 end loop; 4980 4981 Pop_Scope; 4982 Remove_Context (Curr_Comp); 4983 Curr_Scope := S; 4984 4985 else 4986 Remove_Context (Curr_Comp); 4987 end if; 4988 4989 if Ekind (Curr_Unit) = E_Package_Body then 4990 Remove_Context (Library_Unit (Curr_Comp)); 4991 end if; 4992 end if; 4993 4994 S := Scope (S); 4995 end loop; 4996 4997 pragma Assert (Num_Inner < Num_Scopes); 4998 4999 Push_Scope (Standard_Standard); 5000 Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; 5001 5002 -- The inlined package body is analyzed with the configuration state 5003 -- of the context prior to the scope manipulations performed above. 5004 5005 -- ??? shouldn't this also use the warning state of the context prior 5006 -- to the scope manipulations? 5007 5008 Instantiate_Package_Body 5009 (Body_Info => 5010 ((Act_Decl => Act_Decl, 5011 Config_Switches => Config_Attrs, 5012 Current_Sem_Unit => Current_Sem_Unit, 5013 Expander_Status => Expander_Active, 5014 Inst_Node => N, 5015 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 5016 Scope_Suppress => Scope_Suppress, 5017 Warnings => Save_Warnings)), 5018 Inlined_Body => True); 5019 5020 Pop_Scope; 5021 5022 -- Restore context 5023 5024 Set_Is_Immediately_Visible (Gen_Comp, Vis); 5025 5026 -- Reset Generic_Instance flag so that use clauses can be installed 5027 -- in the proper order. (See Use_One_Package for effect of enclosing 5028 -- instances on processing of use clauses). 5029 5030 for J in 1 .. N_Instances loop 5031 Set_Is_Generic_Instance (Instances (J), False); 5032 end loop; 5033 5034 if Removed then 5035 Install_Context (Curr_Comp, Chain => False); 5036 5037 if Present (Curr_Scope) 5038 and then Is_Child_Unit (Curr_Scope) 5039 then 5040 Push_Scope (Curr_Scope); 5041 Set_Is_Immediately_Visible (Curr_Scope); 5042 5043 -- Finally, restore inner scopes as well 5044 5045 for J in reverse 1 .. Num_Inner loop 5046 Push_Scope (Inner_Scopes (J)); 5047 end loop; 5048 end if; 5049 5050 Restore_Scope_Stack (List, Handle_Use => False); 5051 5052 if Present (Curr_Scope) 5053 and then 5054 (In_Private_Part (Curr_Scope) 5055 or else In_Package_Body (Curr_Scope)) 5056 then 5057 -- Install private declaration of ancestor units, which are 5058 -- currently available. Restore_Scope_Stack and Install_Context 5059 -- only install the visible part of parents. 5060 5061 declare 5062 Par : Entity_Id; 5063 begin 5064 Par := Scope (Curr_Scope); 5065 while (Present (Par)) and then Par /= Standard_Standard loop 5066 Install_Private_Declarations (Par); 5067 Par := Scope (Par); 5068 end loop; 5069 end; 5070 end if; 5071 end if; 5072 5073 -- Restore use clauses. For a child unit, use clauses in the parents 5074 -- are restored when installing the context, so only those in inner 5075 -- scopes (and those local to the child unit itself) need to be 5076 -- installed explicitly. 5077 5078 if Is_Child_Unit (Curr_Unit) and then Removed then 5079 for J in reverse 1 .. Num_Inner + 1 loop 5080 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5081 Use_Clauses (J); 5082 Install_Use_Clauses (Use_Clauses (J)); 5083 end loop; 5084 5085 else 5086 for J in reverse 1 .. Num_Scopes loop 5087 Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := 5088 Use_Clauses (J); 5089 Install_Use_Clauses (Use_Clauses (J)); 5090 end loop; 5091 end if; 5092 5093 -- Restore status of instances. If one of them is a body, make its 5094 -- local entities visible again. 5095 5096 declare 5097 E : Entity_Id; 5098 Inst : Entity_Id; 5099 5100 begin 5101 for J in 1 .. N_Instances loop 5102 Inst := Instances (J); 5103 Set_Is_Generic_Instance (Inst, True); 5104 5105 if In_Package_Body (Inst) 5106 or else Ekind_In (S, E_Procedure, E_Function) 5107 then 5108 E := First_Entity (Instances (J)); 5109 while Present (E) loop 5110 Set_Is_Immediately_Visible (E); 5111 Next_Entity (E); 5112 end loop; 5113 end if; 5114 end loop; 5115 end; 5116 5117 -- If generic unit is in current unit, current context is correct. Note 5118 -- that the context is guaranteed to carry the correct SPARK_Mode as no 5119 -- enclosing scopes were removed. 5120 5121 else 5122 Instantiate_Package_Body 5123 (Body_Info => 5124 ((Act_Decl => Act_Decl, 5125 Config_Switches => Save_Config_Switches, 5126 Current_Sem_Unit => Current_Sem_Unit, 5127 Expander_Status => Expander_Active, 5128 Inst_Node => N, 5129 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 5130 Scope_Suppress => Scope_Suppress, 5131 Warnings => Save_Warnings)), 5132 Inlined_Body => True); 5133 end if; 5134 end Inline_Instance_Body; 5135 5136 ------------------------------------- 5137 -- Analyze_Procedure_Instantiation -- 5138 ------------------------------------- 5139 5140 procedure Analyze_Procedure_Instantiation (N : Node_Id) is 5141 begin 5142 Analyze_Subprogram_Instantiation (N, E_Procedure); 5143 end Analyze_Procedure_Instantiation; 5144 5145 ----------------------------------- 5146 -- Need_Subprogram_Instance_Body -- 5147 ----------------------------------- 5148 5149 function Need_Subprogram_Instance_Body 5150 (N : Node_Id; 5151 Subp : Entity_Id) return Boolean 5152 is 5153 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean; 5154 -- Return True if E is an inlined subprogram, an inlined renaming or a 5155 -- subprogram nested in an inlined subprogram. The inlining machinery 5156 -- totally disregards nested subprograms since it considers that they 5157 -- will always be compiled if the parent is (see Inline.Is_Nested). 5158 5159 ------------------------------------ 5160 -- Is_Inlined_Or_Child_Of_Inlined -- 5161 ------------------------------------ 5162 5163 function Is_Inlined_Or_Child_Of_Inlined (E : Entity_Id) return Boolean is 5164 Scop : Entity_Id; 5165 5166 begin 5167 if Is_Inlined (E) or else Is_Inlined (Alias (E)) then 5168 return True; 5169 end if; 5170 5171 Scop := Scope (E); 5172 while Scop /= Standard_Standard loop 5173 if Ekind (Scop) in Subprogram_Kind and then Is_Inlined (Scop) then 5174 return True; 5175 end if; 5176 5177 Scop := Scope (Scop); 5178 end loop; 5179 5180 return False; 5181 end Is_Inlined_Or_Child_Of_Inlined; 5182 5183 begin 5184 -- Must be in the main unit or inlined (or child of inlined) 5185 5186 if (Is_In_Main_Unit (N) or else Is_Inlined_Or_Child_Of_Inlined (Subp)) 5187 5188 -- Must be generating code or analyzing code in ASIS/GNATprove mode 5189 5190 and then (Operating_Mode = Generate_Code 5191 or else (Operating_Mode = Check_Semantics 5192 and then (ASIS_Mode or GNATprove_Mode))) 5193 5194 -- The body is needed when generating code (full expansion), in ASIS 5195 -- mode for other tools, and in GNATprove mode (special expansion) for 5196 -- formal verification of the body itself. 5197 5198 and then (Expander_Active or ASIS_Mode or GNATprove_Mode) 5199 5200 -- No point in inlining if ABE is inevitable 5201 5202 and then not Is_Known_Guaranteed_ABE (N) 5203 5204 -- Or if subprogram is eliminated 5205 5206 and then not Is_Eliminated (Subp) 5207 then 5208 Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp)); 5209 return True; 5210 5211 -- Here if not inlined, or we ignore the inlining 5212 5213 else 5214 return False; 5215 end if; 5216 end Need_Subprogram_Instance_Body; 5217 5218 -------------------------------------- 5219 -- Analyze_Subprogram_Instantiation -- 5220 -------------------------------------- 5221 5222 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 5223 -- must be replaced by gotos which jump to the end of the routine in order 5224 -- to restore the Ghost and SPARK modes. 5225 5226 procedure Analyze_Subprogram_Instantiation 5227 (N : Node_Id; 5228 K : Entity_Kind) 5229 is 5230 Errs : constant Nat := Serious_Errors_Detected; 5231 Gen_Id : constant Node_Id := Name (N); 5232 Inst_Id : constant Entity_Id := Defining_Entity (N); 5233 Anon_Id : constant Entity_Id := 5234 Make_Defining_Identifier (Sloc (Inst_Id), 5235 Chars => New_External_Name (Chars (Inst_Id), 'R')); 5236 Loc : constant Source_Ptr := Sloc (N); 5237 5238 Act_Decl_Id : Entity_Id := Empty; -- init to avoid warning 5239 Act_Decl : Node_Id; 5240 Act_Spec : Node_Id; 5241 Act_Tree : Node_Id; 5242 5243 Env_Installed : Boolean := False; 5244 Gen_Unit : Entity_Id; 5245 Gen_Decl : Node_Id; 5246 Pack_Id : Entity_Id; 5247 Parent_Installed : Boolean := False; 5248 5249 Renaming_List : List_Id; 5250 -- The list of declarations that link formals and actuals of the 5251 -- instance. These are subtype declarations for formal types, and 5252 -- renaming declarations for other formals. The subprogram declaration 5253 -- for the instance is then appended to the list, and the last item on 5254 -- the list is the renaming declaration for the instance. 5255 5256 procedure Analyze_Instance_And_Renamings; 5257 -- The instance must be analyzed in a context that includes the mappings 5258 -- of generic parameters into actuals. We create a package declaration 5259 -- for this purpose, and a subprogram with an internal name within the 5260 -- package. The subprogram instance is simply an alias for the internal 5261 -- subprogram, declared in the current scope. 5262 5263 procedure Build_Subprogram_Renaming; 5264 -- If the subprogram is recursive, there are occurrences of the name of 5265 -- the generic within the body, which must resolve to the current 5266 -- instance. We add a renaming declaration after the declaration, which 5267 -- is available in the instance body, as well as in the analysis of 5268 -- aspects that appear in the generic. This renaming declaration is 5269 -- inserted after the instance declaration which it renames. 5270 5271 ------------------------------------ 5272 -- Analyze_Instance_And_Renamings -- 5273 ------------------------------------ 5274 5275 procedure Analyze_Instance_And_Renamings is 5276 Def_Ent : constant Entity_Id := Defining_Entity (N); 5277 Pack_Decl : Node_Id; 5278 5279 begin 5280 if Nkind (Parent (N)) = N_Compilation_Unit then 5281 5282 -- For the case of a compilation unit, the container package has 5283 -- the same name as the instantiation, to insure that the binder 5284 -- calls the elaboration procedure with the right name. Copy the 5285 -- entity of the instance, which may have compilation level flags 5286 -- (e.g. Is_Child_Unit) set. 5287 5288 Pack_Id := New_Copy (Def_Ent); 5289 5290 else 5291 -- Otherwise we use the name of the instantiation concatenated 5292 -- with its source position to ensure uniqueness if there are 5293 -- several instantiations with the same name. 5294 5295 Pack_Id := 5296 Make_Defining_Identifier (Loc, 5297 Chars => New_External_Name 5298 (Related_Id => Chars (Def_Ent), 5299 Suffix => "GP", 5300 Suffix_Index => Source_Offset (Sloc (Def_Ent)))); 5301 end if; 5302 5303 Pack_Decl := 5304 Make_Package_Declaration (Loc, 5305 Specification => Make_Package_Specification (Loc, 5306 Defining_Unit_Name => Pack_Id, 5307 Visible_Declarations => Renaming_List, 5308 End_Label => Empty)); 5309 5310 Set_Instance_Spec (N, Pack_Decl); 5311 Set_Is_Generic_Instance (Pack_Id); 5312 Set_Debug_Info_Needed (Pack_Id); 5313 5314 -- Case of not a compilation unit 5315 5316 if Nkind (Parent (N)) /= N_Compilation_Unit then 5317 Mark_Rewrite_Insertion (Pack_Decl); 5318 Insert_Before (N, Pack_Decl); 5319 Set_Has_Completion (Pack_Id); 5320 5321 -- Case of an instantiation that is a compilation unit 5322 5323 -- Place declaration on current node so context is complete for 5324 -- analysis (including nested instantiations), and for use in a 5325 -- context_clause (see Analyze_With_Clause). 5326 5327 else 5328 Set_Unit (Parent (N), Pack_Decl); 5329 Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); 5330 end if; 5331 5332 Analyze (Pack_Decl); 5333 Check_Formal_Packages (Pack_Id); 5334 5335 -- Body of the enclosing package is supplied when instantiating the 5336 -- subprogram body, after semantic analysis is completed. 5337 5338 if Nkind (Parent (N)) = N_Compilation_Unit then 5339 5340 -- Remove package itself from visibility, so it does not 5341 -- conflict with subprogram. 5342 5343 Set_Name_Entity_Id (Chars (Pack_Id), Homonym (Pack_Id)); 5344 5345 -- Set name and scope of internal subprogram so that the proper 5346 -- external name will be generated. The proper scope is the scope 5347 -- of the wrapper package. We need to generate debugging info for 5348 -- the internal subprogram, so set flag accordingly. 5349 5350 Set_Chars (Anon_Id, Chars (Defining_Entity (N))); 5351 Set_Scope (Anon_Id, Scope (Pack_Id)); 5352 5353 -- Mark wrapper package as referenced, to avoid spurious warnings 5354 -- if the instantiation appears in various with_ clauses of 5355 -- subunits of the main unit. 5356 5357 Set_Referenced (Pack_Id); 5358 end if; 5359 5360 Set_Is_Generic_Instance (Anon_Id); 5361 Set_Debug_Info_Needed (Anon_Id); 5362 Act_Decl_Id := New_Copy (Anon_Id); 5363 5364 Set_Parent (Act_Decl_Id, Parent (Anon_Id)); 5365 Set_Chars (Act_Decl_Id, Chars (Defining_Entity (N))); 5366 Set_Sloc (Act_Decl_Id, Sloc (Defining_Entity (N))); 5367 5368 -- Subprogram instance comes from source only if generic does 5369 5370 Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit)); 5371 5372 -- If the instance is a child unit, mark the Id accordingly. Mark 5373 -- the anonymous entity as well, which is the real subprogram and 5374 -- which is used when the instance appears in a context clause. 5375 -- Similarly, propagate the Is_Eliminated flag to handle properly 5376 -- nested eliminated subprograms. 5377 5378 Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); 5379 Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); 5380 New_Overloaded_Entity (Act_Decl_Id); 5381 Check_Eliminated (Act_Decl_Id); 5382 Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); 5383 5384 if Nkind (Parent (N)) = N_Compilation_Unit then 5385 5386 -- In compilation unit case, kill elaboration checks on the 5387 -- instantiation, since they are never needed - the body is 5388 -- instantiated at the same point as the spec. 5389 5390 if Legacy_Elaboration_Checks then 5391 Set_Kill_Elaboration_Checks (Act_Decl_Id); 5392 Set_Suppress_Elaboration_Warnings (Act_Decl_Id); 5393 end if; 5394 5395 Set_Is_Compilation_Unit (Anon_Id); 5396 Set_Cunit_Entity (Current_Sem_Unit, Pack_Id); 5397 end if; 5398 5399 -- The instance is not a freezing point for the new subprogram. 5400 -- The anonymous subprogram may have a freeze node, created for 5401 -- some delayed aspects. This freeze node must not be inherited 5402 -- by the visible subprogram entity. 5403 5404 Set_Is_Frozen (Act_Decl_Id, False); 5405 Set_Freeze_Node (Act_Decl_Id, Empty); 5406 5407 if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then 5408 Valid_Operator_Definition (Act_Decl_Id); 5409 end if; 5410 5411 Set_Alias (Act_Decl_Id, Anon_Id); 5412 Set_Has_Completion (Act_Decl_Id); 5413 Set_Related_Instance (Pack_Id, Act_Decl_Id); 5414 5415 if Nkind (Parent (N)) = N_Compilation_Unit then 5416 Set_Body_Required (Parent (N), False); 5417 end if; 5418 end Analyze_Instance_And_Renamings; 5419 5420 ------------------------------- 5421 -- Build_Subprogram_Renaming -- 5422 ------------------------------- 5423 5424 procedure Build_Subprogram_Renaming is 5425 Renaming_Decl : Node_Id; 5426 Unit_Renaming : Node_Id; 5427 5428 begin 5429 Unit_Renaming := 5430 Make_Subprogram_Renaming_Declaration (Loc, 5431 Specification => 5432 Copy_Generic_Node 5433 (Specification (Original_Node (Gen_Decl)), 5434 Empty, 5435 Instantiating => True), 5436 Name => New_Occurrence_Of (Anon_Id, Loc)); 5437 5438 -- The generic may be a child unit. The renaming needs an identifier 5439 -- with the proper name. 5440 5441 Set_Defining_Unit_Name (Specification (Unit_Renaming), 5442 Make_Defining_Identifier (Loc, Chars (Gen_Unit))); 5443 5444 -- If there is a formal subprogram with the same name as the unit 5445 -- itself, do not add this renaming declaration, to prevent 5446 -- ambiguities when there is a call with that name in the body. 5447 -- This is a partial and ugly fix for one ACATS test. ??? 5448 5449 Renaming_Decl := First (Renaming_List); 5450 while Present (Renaming_Decl) loop 5451 if Nkind (Renaming_Decl) = N_Subprogram_Renaming_Declaration 5452 and then 5453 Chars (Defining_Entity (Renaming_Decl)) = Chars (Gen_Unit) 5454 then 5455 exit; 5456 end if; 5457 5458 Next (Renaming_Decl); 5459 end loop; 5460 5461 if No (Renaming_Decl) then 5462 Append (Unit_Renaming, Renaming_List); 5463 end if; 5464 end Build_Subprogram_Renaming; 5465 5466 -- Local variables 5467 5468 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 5469 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 5470 Saved_ISMP : constant Boolean := 5471 Ignore_SPARK_Mode_Pragmas_In_Instance; 5472 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 5473 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 5474 -- Save the Ghost and SPARK mode-related data to restore on exit 5475 5476 Vis_Prims_List : Elist_Id := No_Elist; 5477 -- List of primitives made temporarily visible in the instantiation 5478 -- to match the visibility of the formal type 5479 5480 -- Start of processing for Analyze_Subprogram_Instantiation 5481 5482 begin 5483 -- Preserve relevant elaboration-related attributes of the context which 5484 -- are no longer available or very expensive to recompute once analysis, 5485 -- resolution, and expansion are over. 5486 5487 Mark_Elaboration_Attributes 5488 (N_Id => N, 5489 Checks => True, 5490 Level => True, 5491 Modes => True, 5492 Warnings => True); 5493 5494 Check_SPARK_05_Restriction ("generic is not allowed", N); 5495 5496 -- Very first thing: check for special Text_IO unit in case we are 5497 -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course 5498 -- such an instantiation is bogus (these are packages, not subprograms), 5499 -- but we get a better error message if we do this. 5500 5501 Check_Text_IO_Special_Unit (Gen_Id); 5502 5503 -- Make node global for error reporting 5504 5505 Instantiation_Node := N; 5506 5507 -- For package instantiations we turn off style checks, because they 5508 -- will have been emitted in the generic. For subprogram instantiations 5509 -- we want to apply at least the check on overriding indicators so we 5510 -- do not modify the style check status. 5511 5512 -- The renaming declarations for the actuals do not come from source and 5513 -- will not generate spurious warnings. 5514 5515 Preanalyze_Actuals (N); 5516 5517 Init_Env; 5518 Env_Installed := True; 5519 Check_Generic_Child_Unit (Gen_Id, Parent_Installed); 5520 Gen_Unit := Entity (Gen_Id); 5521 5522 -- A subprogram instantiation is Ghost when it is subject to pragma 5523 -- Ghost or the generic template is Ghost. Set the mode now to ensure 5524 -- that any nodes generated during analysis and expansion are marked as 5525 -- Ghost. 5526 5527 Mark_And_Set_Ghost_Instantiation (N, Gen_Unit); 5528 5529 Generate_Reference (Gen_Unit, Gen_Id); 5530 5531 if Nkind (Gen_Id) = N_Identifier 5532 and then Chars (Gen_Unit) = Chars (Defining_Entity (N)) 5533 then 5534 Error_Msg_NE 5535 ("& is hidden within declaration of instance", Gen_Id, Gen_Unit); 5536 end if; 5537 5538 if Etype (Gen_Unit) = Any_Type then 5539 Restore_Env; 5540 goto Leave; 5541 end if; 5542 5543 -- Verify that it is a generic subprogram of the right kind, and that 5544 -- it does not lead to a circular instantiation. 5545 5546 if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then 5547 Error_Msg_NE 5548 ("& is not the name of a generic procedure", Gen_Id, Gen_Unit); 5549 5550 elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then 5551 Error_Msg_NE 5552 ("& is not the name of a generic function", Gen_Id, Gen_Unit); 5553 5554 elsif In_Open_Scopes (Gen_Unit) then 5555 Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); 5556 5557 else 5558 Set_Ekind (Inst_Id, K); 5559 Set_Scope (Inst_Id, Current_Scope); 5560 5561 Set_Entity (Gen_Id, Gen_Unit); 5562 Set_Is_Instantiated (Gen_Unit); 5563 5564 if In_Extended_Main_Source_Unit (N) then 5565 Generate_Reference (Gen_Unit, N); 5566 end if; 5567 5568 -- If renaming, get original unit 5569 5570 if Present (Renamed_Object (Gen_Unit)) 5571 and then Ekind_In (Renamed_Object (Gen_Unit), E_Generic_Procedure, 5572 E_Generic_Function) 5573 then 5574 Gen_Unit := Renamed_Object (Gen_Unit); 5575 Set_Is_Instantiated (Gen_Unit); 5576 Generate_Reference (Gen_Unit, N); 5577 end if; 5578 5579 if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then 5580 Error_Msg_Node_2 := Current_Scope; 5581 Error_Msg_NE 5582 ("circular Instantiation: & instantiated in &!", N, Gen_Unit); 5583 Circularity_Detected := True; 5584 Restore_Hidden_Primitives (Vis_Prims_List); 5585 goto Leave; 5586 end if; 5587 5588 Gen_Decl := Unit_Declaration_Node (Gen_Unit); 5589 5590 -- Initialize renamings map, for error checking 5591 5592 Generic_Renamings.Set_Last (0); 5593 Generic_Renamings_HTable.Reset; 5594 5595 Create_Instantiation_Source (N, Gen_Unit, S_Adjustment); 5596 5597 -- Copy original generic tree, to produce text for instantiation 5598 5599 Act_Tree := 5600 Copy_Generic_Node 5601 (Original_Node (Gen_Decl), Empty, Instantiating => True); 5602 5603 -- Inherit overriding indicator from instance node 5604 5605 Act_Spec := Specification (Act_Tree); 5606 Set_Must_Override (Act_Spec, Must_Override (N)); 5607 Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); 5608 5609 Renaming_List := 5610 Analyze_Associations 5611 (I_Node => N, 5612 Formals => Generic_Formal_Declarations (Act_Tree), 5613 F_Copy => Generic_Formal_Declarations (Gen_Decl)); 5614 5615 Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); 5616 5617 -- The subprogram itself cannot contain a nested instance, so the 5618 -- current parent is left empty. 5619 5620 Set_Instance_Env (Gen_Unit, Empty); 5621 5622 -- Build the subprogram declaration, which does not appear in the 5623 -- generic template, and give it a sloc consistent with that of the 5624 -- template. 5625 5626 Set_Defining_Unit_Name (Act_Spec, Anon_Id); 5627 Set_Generic_Parent (Act_Spec, Gen_Unit); 5628 Act_Decl := 5629 Make_Subprogram_Declaration (Sloc (Act_Spec), 5630 Specification => Act_Spec); 5631 5632 -- The aspects have been copied previously, but they have to be 5633 -- linked explicitly to the new subprogram declaration. Explicit 5634 -- pre/postconditions on the instance are analyzed below, in a 5635 -- separate step. 5636 5637 Move_Aspects (Act_Tree, To => Act_Decl); 5638 Set_Categorization_From_Pragmas (Act_Decl); 5639 5640 if Parent_Installed then 5641 Hide_Current_Scope; 5642 end if; 5643 5644 Append (Act_Decl, Renaming_List); 5645 5646 -- Contract-related source pragmas that follow a generic subprogram 5647 -- must be instantiated explicitly because they are not part of the 5648 -- subprogram template. 5649 5650 Instantiate_Subprogram_Contract 5651 (Original_Node (Gen_Decl), Renaming_List); 5652 5653 Build_Subprogram_Renaming; 5654 5655 -- If the context of the instance is subject to SPARK_Mode "off" or 5656 -- the annotation is altogether missing, set the global flag which 5657 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within 5658 -- the instance. This should be done prior to analyzing the instance. 5659 5660 if SPARK_Mode /= On then 5661 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 5662 end if; 5663 5664 -- If the context of an instance is not subject to SPARK_Mode "off", 5665 -- and the generic spec is subject to an explicit SPARK_Mode pragma, 5666 -- the latter should be the one applicable to the instance. 5667 5668 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5669 and then Saved_SM /= Off 5670 and then Present (SPARK_Pragma (Gen_Unit)) 5671 then 5672 Set_SPARK_Mode (Gen_Unit); 5673 end if; 5674 5675 Analyze_Instance_And_Renamings; 5676 5677 -- Restore SPARK_Mode from the context after analysis of the package 5678 -- declaration, so that the SPARK_Mode on the generic spec does not 5679 -- apply to the pending instance for the instance body. 5680 5681 if not Ignore_SPARK_Mode_Pragmas_In_Instance 5682 and then Saved_SM /= Off 5683 and then Present (SPARK_Pragma (Gen_Unit)) 5684 then 5685 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5686 end if; 5687 5688 -- If the generic is marked Import (Intrinsic), then so is the 5689 -- instance. This indicates that there is no body to instantiate. If 5690 -- generic is marked inline, so it the instance, and the anonymous 5691 -- subprogram it renames. If inlined, or else if inlining is enabled 5692 -- for the compilation, we generate the instance body even if it is 5693 -- not within the main unit. 5694 5695 if Is_Intrinsic_Subprogram (Gen_Unit) then 5696 Set_Is_Intrinsic_Subprogram (Anon_Id); 5697 Set_Is_Intrinsic_Subprogram (Act_Decl_Id); 5698 5699 if Chars (Gen_Unit) = Name_Unchecked_Conversion then 5700 Validate_Unchecked_Conversion (N, Act_Decl_Id); 5701 end if; 5702 end if; 5703 5704 -- Inherit convention from generic unit. Intrinsic convention, as for 5705 -- an instance of unchecked conversion, is not inherited because an 5706 -- explicit Ada instance has been created. 5707 5708 if Has_Convention_Pragma (Gen_Unit) 5709 and then Convention (Gen_Unit) /= Convention_Intrinsic 5710 then 5711 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 5712 Set_Is_Exported (Act_Decl_Id, Is_Exported (Gen_Unit)); 5713 end if; 5714 5715 Generate_Definition (Act_Decl_Id); 5716 5717 -- Inherit all inlining-related flags which apply to the generic in 5718 -- the subprogram and its declaration. 5719 5720 Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); 5721 Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); 5722 5723 Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); 5724 Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); 5725 5726 Set_Has_Pragma_Inline_Always 5727 (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5728 Set_Has_Pragma_Inline_Always 5729 (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); 5730 5731 Set_Has_Pragma_No_Inline 5732 (Act_Decl_Id, Has_Pragma_No_Inline (Gen_Unit)); 5733 Set_Has_Pragma_No_Inline 5734 (Anon_Id, Has_Pragma_No_Inline (Gen_Unit)); 5735 5736 -- Propagate No_Return if pragma applied to generic unit. This must 5737 -- be done explicitly because pragma does not appear in generic 5738 -- declaration (unlike the aspect case). 5739 5740 if No_Return (Gen_Unit) then 5741 Set_No_Return (Act_Decl_Id); 5742 Set_No_Return (Anon_Id); 5743 end if; 5744 5745 -- Mark both the instance spec and the anonymous package in case the 5746 -- body is instantiated at a later pass. This preserves the original 5747 -- context in effect for the body. 5748 5749 if SPARK_Mode /= On then 5750 Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id); 5751 Set_Ignore_SPARK_Mode_Pragmas (Anon_Id); 5752 end if; 5753 5754 if Legacy_Elaboration_Checks 5755 and then not Is_Intrinsic_Subprogram (Gen_Unit) 5756 then 5757 Check_Elab_Instantiation (N); 5758 end if; 5759 5760 -- Save the scenario for later examination by the ABE Processing 5761 -- phase. 5762 5763 Record_Elaboration_Scenario (N); 5764 5765 -- The instantiation results in a guaranteed ABE. Create a completing 5766 -- body for the subprogram declaration because the real body will not 5767 -- be instantiated. 5768 5769 if Is_Known_Guaranteed_ABE (N) then 5770 Provide_Completing_Bodies (Instance_Spec (N)); 5771 end if; 5772 5773 if Is_Dispatching_Operation (Act_Decl_Id) 5774 and then Ada_Version >= Ada_2005 5775 then 5776 declare 5777 Formal : Entity_Id; 5778 5779 begin 5780 Formal := First_Formal (Act_Decl_Id); 5781 while Present (Formal) loop 5782 if Ekind (Etype (Formal)) = E_Anonymous_Access_Type 5783 and then Is_Controlling_Formal (Formal) 5784 and then not Can_Never_Be_Null (Formal) 5785 then 5786 Error_Msg_NE 5787 ("access parameter& is controlling,", N, Formal); 5788 Error_Msg_NE 5789 ("\corresponding parameter of & must be explicitly " 5790 & "null-excluding", N, Gen_Id); 5791 end if; 5792 5793 Next_Formal (Formal); 5794 end loop; 5795 end; 5796 end if; 5797 5798 Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); 5799 5800 Validate_Categorization_Dependency (N, Act_Decl_Id); 5801 5802 if not Is_Intrinsic_Subprogram (Act_Decl_Id) then 5803 Inherit_Context (Gen_Decl, N); 5804 5805 Restore_Private_Views (Pack_Id, False); 5806 5807 -- If the context requires a full instantiation, mark node for 5808 -- subsequent construction of the body. 5809 5810 if Need_Subprogram_Instance_Body (N, Act_Decl_Id) then 5811 Check_Forward_Instantiation (Gen_Decl); 5812 5813 -- The wrapper package is always delayed, because it does not 5814 -- constitute a freeze point, but to insure that the freeze node 5815 -- is placed properly, it is created directly when instantiating 5816 -- the body (otherwise the freeze node might appear to early for 5817 -- nested instantiations). For ASIS purposes, indicate that the 5818 -- wrapper package has replaced the instantiation node. 5819 5820 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5821 Rewrite (N, Unit (Parent (N))); 5822 Set_Unit (Parent (N), N); 5823 end if; 5824 5825 -- Replace instance node for library-level instantiations of 5826 -- intrinsic subprograms, for ASIS use. 5827 5828 elsif Nkind (Parent (N)) = N_Compilation_Unit then 5829 Rewrite (N, Unit (Parent (N))); 5830 Set_Unit (Parent (N), N); 5831 end if; 5832 5833 if Parent_Installed then 5834 Remove_Parent; 5835 end if; 5836 5837 Restore_Hidden_Primitives (Vis_Prims_List); 5838 Restore_Env; 5839 Env_Installed := False; 5840 Generic_Renamings.Set_Last (0); 5841 Generic_Renamings_HTable.Reset; 5842 end if; 5843 5844 <<Leave>> 5845 -- Analyze aspects in declaration if no errors appear in the instance. 5846 5847 if Has_Aspects (N) and then Serious_Errors_Detected = Errs then 5848 Analyze_Aspect_Specifications (N, Act_Decl_Id); 5849 end if; 5850 5851 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5852 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5853 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5854 5855 exception 5856 when Instantiation_Error => 5857 if Parent_Installed then 5858 Remove_Parent; 5859 end if; 5860 5861 if Env_Installed then 5862 Restore_Env; 5863 end if; 5864 5865 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 5866 Restore_Ghost_Region (Saved_GM, Saved_IGR); 5867 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 5868 end Analyze_Subprogram_Instantiation; 5869 5870 ------------------------- 5871 -- Get_Associated_Node -- 5872 ------------------------- 5873 5874 function Get_Associated_Node (N : Node_Id) return Node_Id is 5875 Assoc : Node_Id; 5876 5877 begin 5878 Assoc := Associated_Node (N); 5879 5880 if Nkind (Assoc) /= Nkind (N) then 5881 return Assoc; 5882 5883 elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then 5884 return Assoc; 5885 5886 else 5887 -- If the node is part of an inner generic, it may itself have been 5888 -- remapped into a further generic copy. Associated_Node is otherwise 5889 -- used for the entity of the node, and will be of a different node 5890 -- kind, or else N has been rewritten as a literal or function call. 5891 5892 while Present (Associated_Node (Assoc)) 5893 and then Nkind (Associated_Node (Assoc)) = Nkind (Assoc) 5894 loop 5895 Assoc := Associated_Node (Assoc); 5896 end loop; 5897 5898 -- Follow an additional link in case the final node was rewritten. 5899 -- This can only happen with nested generic units. 5900 5901 if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op) 5902 and then Present (Associated_Node (Assoc)) 5903 and then (Nkind_In (Associated_Node (Assoc), N_Function_Call, 5904 N_Explicit_Dereference, 5905 N_Integer_Literal, 5906 N_Real_Literal, 5907 N_String_Literal)) 5908 then 5909 Assoc := Associated_Node (Assoc); 5910 end if; 5911 5912 -- An additional special case: an unconstrained type in an object 5913 -- declaration may have been rewritten as a local subtype constrained 5914 -- by the expression in the declaration. We need to recover the 5915 -- original entity, which may be global. 5916 5917 if Present (Original_Node (Assoc)) 5918 and then Nkind (Parent (N)) = N_Object_Declaration 5919 then 5920 Assoc := Original_Node (Assoc); 5921 end if; 5922 5923 return Assoc; 5924 end if; 5925 end Get_Associated_Node; 5926 5927 ---------------------------- 5928 -- Build_Function_Wrapper -- 5929 ---------------------------- 5930 5931 function Build_Function_Wrapper 5932 (Formal_Subp : Entity_Id; 5933 Actual_Subp : Entity_Id) return Node_Id 5934 is 5935 Loc : constant Source_Ptr := Sloc (Current_Scope); 5936 Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp)); 5937 Actuals : List_Id; 5938 Decl : Node_Id; 5939 Func_Name : Node_Id; 5940 Func : Entity_Id; 5941 Parm_Type : Node_Id; 5942 Profile : List_Id := New_List; 5943 Spec : Node_Id; 5944 Act_F : Entity_Id; 5945 Form_F : Entity_Id; 5946 New_F : Entity_Id; 5947 5948 begin 5949 Func_Name := New_Occurrence_Of (Actual_Subp, Loc); 5950 5951 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 5952 Set_Ekind (Func, E_Function); 5953 Set_Is_Generic_Actual_Subprogram (Func); 5954 5955 Actuals := New_List; 5956 Profile := New_List; 5957 5958 Act_F := First_Formal (Actual_Subp); 5959 Form_F := First_Formal (Formal_Subp); 5960 while Present (Form_F) loop 5961 5962 -- Create new formal for profile of wrapper, and add a reference 5963 -- to it in the list of actuals for the enclosing call. The name 5964 -- must be that of the formal in the formal subprogram, because 5965 -- calls to it in the generic body may use named associations. 5966 5967 New_F := Make_Defining_Identifier (Loc, Chars (Form_F)); 5968 5969 Parm_Type := 5970 New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc); 5971 5972 Append_To (Profile, 5973 Make_Parameter_Specification (Loc, 5974 Defining_Identifier => New_F, 5975 Parameter_Type => Parm_Type)); 5976 5977 Append_To (Actuals, New_Occurrence_Of (New_F, Loc)); 5978 Next_Formal (Form_F); 5979 5980 if Present (Act_F) then 5981 Next_Formal (Act_F); 5982 end if; 5983 end loop; 5984 5985 Spec := 5986 Make_Function_Specification (Loc, 5987 Defining_Unit_Name => Func, 5988 Parameter_Specifications => Profile, 5989 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 5990 5991 Decl := 5992 Make_Expression_Function (Loc, 5993 Specification => Spec, 5994 Expression => 5995 Make_Function_Call (Loc, 5996 Name => Func_Name, 5997 Parameter_Associations => Actuals)); 5998 5999 return Decl; 6000 end Build_Function_Wrapper; 6001 6002 ---------------------------- 6003 -- Build_Operator_Wrapper -- 6004 ---------------------------- 6005 6006 function Build_Operator_Wrapper 6007 (Formal_Subp : Entity_Id; 6008 Actual_Subp : Entity_Id) return Node_Id 6009 is 6010 Loc : constant Source_Ptr := Sloc (Current_Scope); 6011 Ret_Type : constant Entity_Id := 6012 Get_Instance_Of (Etype (Formal_Subp)); 6013 Op_Type : constant Entity_Id := 6014 Get_Instance_Of (Etype (First_Formal (Formal_Subp))); 6015 Is_Binary : constant Boolean := 6016 Present (Next_Formal (First_Formal (Formal_Subp))); 6017 6018 Decl : Node_Id; 6019 Expr : Node_Id := Empty; 6020 F1, F2 : Entity_Id; 6021 Func : Entity_Id; 6022 Op_Name : Name_Id; 6023 Spec : Node_Id; 6024 L, R : Node_Id; 6025 6026 begin 6027 Op_Name := Chars (Actual_Subp); 6028 6029 -- Create entities for wrapper function and its formals 6030 6031 F1 := Make_Temporary (Loc, 'A'); 6032 F2 := Make_Temporary (Loc, 'B'); 6033 L := New_Occurrence_Of (F1, Loc); 6034 R := New_Occurrence_Of (F2, Loc); 6035 6036 Func := Make_Defining_Identifier (Loc, Chars (Formal_Subp)); 6037 Set_Ekind (Func, E_Function); 6038 Set_Is_Generic_Actual_Subprogram (Func); 6039 6040 Spec := 6041 Make_Function_Specification (Loc, 6042 Defining_Unit_Name => Func, 6043 Parameter_Specifications => New_List ( 6044 Make_Parameter_Specification (Loc, 6045 Defining_Identifier => F1, 6046 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))), 6047 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 6048 6049 if Is_Binary then 6050 Append_To (Parameter_Specifications (Spec), 6051 Make_Parameter_Specification (Loc, 6052 Defining_Identifier => F2, 6053 Parameter_Type => New_Occurrence_Of (Op_Type, Loc))); 6054 end if; 6055 6056 -- Build expression as a function call, or as an operator node 6057 -- that corresponds to the name of the actual, starting with 6058 -- binary operators. 6059 6060 if Op_Name not in Any_Operator_Name then 6061 Expr := 6062 Make_Function_Call (Loc, 6063 Name => 6064 New_Occurrence_Of (Actual_Subp, Loc), 6065 Parameter_Associations => New_List (L)); 6066 6067 if Is_Binary then 6068 Append_To (Parameter_Associations (Expr), R); 6069 end if; 6070 6071 -- Binary operators 6072 6073 elsif Is_Binary then 6074 if Op_Name = Name_Op_And then 6075 Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R); 6076 elsif Op_Name = Name_Op_Or then 6077 Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R); 6078 elsif Op_Name = Name_Op_Xor then 6079 Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R); 6080 elsif Op_Name = Name_Op_Eq then 6081 Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); 6082 elsif Op_Name = Name_Op_Ne then 6083 Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); 6084 elsif Op_Name = Name_Op_Le then 6085 Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R); 6086 elsif Op_Name = Name_Op_Gt then 6087 Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R); 6088 elsif Op_Name = Name_Op_Ge then 6089 Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R); 6090 elsif Op_Name = Name_Op_Lt then 6091 Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R); 6092 elsif Op_Name = Name_Op_Add then 6093 Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R); 6094 elsif Op_Name = Name_Op_Subtract then 6095 Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R); 6096 elsif Op_Name = Name_Op_Concat then 6097 Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R); 6098 elsif Op_Name = Name_Op_Multiply then 6099 Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R); 6100 elsif Op_Name = Name_Op_Divide then 6101 Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R); 6102 elsif Op_Name = Name_Op_Mod then 6103 Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R); 6104 elsif Op_Name = Name_Op_Rem then 6105 Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R); 6106 elsif Op_Name = Name_Op_Expon then 6107 Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R); 6108 end if; 6109 6110 -- Unary operators 6111 6112 else 6113 if Op_Name = Name_Op_Add then 6114 Expr := Make_Op_Plus (Loc, Right_Opnd => L); 6115 elsif Op_Name = Name_Op_Subtract then 6116 Expr := Make_Op_Minus (Loc, Right_Opnd => L); 6117 elsif Op_Name = Name_Op_Abs then 6118 Expr := Make_Op_Abs (Loc, Right_Opnd => L); 6119 elsif Op_Name = Name_Op_Not then 6120 Expr := Make_Op_Not (Loc, Right_Opnd => L); 6121 end if; 6122 end if; 6123 6124 Decl := 6125 Make_Expression_Function (Loc, 6126 Specification => Spec, 6127 Expression => Expr); 6128 6129 return Decl; 6130 end Build_Operator_Wrapper; 6131 6132 ------------------------------------------- 6133 -- Build_Instance_Compilation_Unit_Nodes -- 6134 ------------------------------------------- 6135 6136 procedure Build_Instance_Compilation_Unit_Nodes 6137 (N : Node_Id; 6138 Act_Body : Node_Id; 6139 Act_Decl : Node_Id) 6140 is 6141 Decl_Cunit : Node_Id; 6142 Body_Cunit : Node_Id; 6143 Citem : Node_Id; 6144 New_Main : constant Entity_Id := Defining_Entity (Act_Decl); 6145 Old_Main : constant Entity_Id := Cunit_Entity (Main_Unit); 6146 6147 begin 6148 -- A new compilation unit node is built for the instance declaration 6149 6150 Decl_Cunit := 6151 Make_Compilation_Unit (Sloc (N), 6152 Context_Items => Empty_List, 6153 Unit => Act_Decl, 6154 Aux_Decls_Node => Make_Compilation_Unit_Aux (Sloc (N))); 6155 6156 Set_Parent_Spec (Act_Decl, Parent_Spec (N)); 6157 6158 -- The new compilation unit is linked to its body, but both share the 6159 -- same file, so we do not set Body_Required on the new unit so as not 6160 -- to create a spurious dependency on a non-existent body in the ali. 6161 -- This simplifies CodePeer unit traversal. 6162 6163 -- We use the original instantiation compilation unit as the resulting 6164 -- compilation unit of the instance, since this is the main unit. 6165 6166 Rewrite (N, Act_Body); 6167 6168 -- Propagate the aspect specifications from the package body template to 6169 -- the instantiated version of the package body. 6170 6171 if Has_Aspects (Act_Body) then 6172 Set_Aspect_Specifications 6173 (N, New_Copy_List_Tree (Aspect_Specifications (Act_Body))); 6174 end if; 6175 6176 Body_Cunit := Parent (N); 6177 6178 -- The two compilation unit nodes are linked by the Library_Unit field 6179 6180 Set_Library_Unit (Decl_Cunit, Body_Cunit); 6181 Set_Library_Unit (Body_Cunit, Decl_Cunit); 6182 6183 -- Preserve the private nature of the package if needed 6184 6185 Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit)); 6186 6187 -- If the instance is not the main unit, its context, categorization 6188 -- and elaboration entity are not relevant to the compilation. 6189 6190 if Body_Cunit /= Cunit (Main_Unit) then 6191 Make_Instance_Unit (Body_Cunit, In_Main => False); 6192 return; 6193 end if; 6194 6195 -- The context clause items on the instantiation, which are now attached 6196 -- to the body compilation unit (since the body overwrote the original 6197 -- instantiation node), semantically belong on the spec, so copy them 6198 -- there. It's harmless to leave them on the body as well. In fact one 6199 -- could argue that they belong in both places. 6200 6201 Citem := First (Context_Items (Body_Cunit)); 6202 while Present (Citem) loop 6203 Append (New_Copy (Citem), Context_Items (Decl_Cunit)); 6204 Next (Citem); 6205 end loop; 6206 6207 -- Propagate categorization flags on packages, so that they appear in 6208 -- the ali file for the spec of the unit. 6209 6210 if Ekind (New_Main) = E_Package then 6211 Set_Is_Pure (Old_Main, Is_Pure (New_Main)); 6212 Set_Is_Preelaborated (Old_Main, Is_Preelaborated (New_Main)); 6213 Set_Is_Remote_Types (Old_Main, Is_Remote_Types (New_Main)); 6214 Set_Is_Shared_Passive (Old_Main, Is_Shared_Passive (New_Main)); 6215 Set_Is_Remote_Call_Interface 6216 (Old_Main, Is_Remote_Call_Interface (New_Main)); 6217 end if; 6218 6219 -- Make entry in Units table, so that binder can generate call to 6220 -- elaboration procedure for body, if any. 6221 6222 Make_Instance_Unit (Body_Cunit, In_Main => True); 6223 Main_Unit_Entity := New_Main; 6224 Set_Cunit_Entity (Main_Unit, Main_Unit_Entity); 6225 6226 -- Build elaboration entity, since the instance may certainly generate 6227 -- elaboration code requiring a flag for protection. 6228 6229 Build_Elaboration_Entity (Decl_Cunit, New_Main); 6230 end Build_Instance_Compilation_Unit_Nodes; 6231 6232 ----------------------------- 6233 -- Check_Access_Definition -- 6234 ----------------------------- 6235 6236 procedure Check_Access_Definition (N : Node_Id) is 6237 begin 6238 pragma Assert 6239 (Ada_Version >= Ada_2005 and then Present (Access_Definition (N))); 6240 null; 6241 end Check_Access_Definition; 6242 6243 ----------------------------------- 6244 -- Check_Formal_Package_Instance -- 6245 ----------------------------------- 6246 6247 -- If the formal has specific parameters, they must match those of the 6248 -- actual. Both of them are instances, and the renaming declarations for 6249 -- their formal parameters appear in the same order in both. The analyzed 6250 -- formal has been analyzed in the context of the current instance. 6251 6252 procedure Check_Formal_Package_Instance 6253 (Formal_Pack : Entity_Id; 6254 Actual_Pack : Entity_Id) 6255 is 6256 E1 : Entity_Id := First_Entity (Actual_Pack); 6257 E2 : Entity_Id := First_Entity (Formal_Pack); 6258 Prev_E1 : Entity_Id; 6259 6260 Expr1 : Node_Id; 6261 Expr2 : Node_Id; 6262 6263 procedure Check_Mismatch (B : Boolean); 6264 -- Common error routine for mismatch between the parameters of the 6265 -- actual instance and those of the formal package. 6266 6267 function Is_Defaulted (Param : Entity_Id) return Boolean; 6268 -- If the formal package has partly box-initialized formals, skip 6269 -- conformance check for these formals. Previously the code assumed 6270 -- that box initialization for a formal package applied to all its 6271 -- formal parameters. 6272 6273 function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; 6274 -- The formal may come from a nested formal package, and the actual may 6275 -- have been constant-folded. To determine whether the two denote the 6276 -- same entity we may have to traverse several definitions to recover 6277 -- the ultimate entity that they refer to. 6278 6279 function Same_Instantiated_Function (E1, E2 : Entity_Id) return Boolean; 6280 -- The formal and the actual must be identical, but if both are 6281 -- given by attributes they end up renaming different generated bodies, 6282 -- and we must verify that the attributes themselves match. 6283 6284 function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; 6285 -- Similarly, if the formal comes from a nested formal package, the 6286 -- actual may designate the formal through multiple renamings, which 6287 -- have to be followed to determine the original variable in question. 6288 6289 -------------------- 6290 -- Check_Mismatch -- 6291 -------------------- 6292 6293 procedure Check_Mismatch (B : Boolean) is 6294 -- A Formal_Type_Declaration for a derived private type is rewritten 6295 -- as a private extension decl. (see Analyze_Formal_Derived_Type), 6296 -- which is why we examine the original node. 6297 6298 Kind : constant Node_Kind := Nkind (Original_Node (Parent (E2))); 6299 6300 begin 6301 if Kind = N_Formal_Type_Declaration then 6302 return; 6303 6304 elsif Nkind_In (Kind, N_Formal_Object_Declaration, 6305 N_Formal_Package_Declaration) 6306 or else Kind in N_Formal_Subprogram_Declaration 6307 then 6308 null; 6309 6310 -- Ada 2012: If both formal and actual are incomplete types they 6311 -- are conformant. 6312 6313 elsif Is_Incomplete_Type (E1) and then Is_Incomplete_Type (E2) then 6314 null; 6315 6316 elsif B then 6317 Error_Msg_NE 6318 ("actual for & in actual instance does not match formal", 6319 Parent (Actual_Pack), E1); 6320 end if; 6321 end Check_Mismatch; 6322 6323 ------------------ 6324 -- Is_Defaulted -- 6325 ------------------ 6326 6327 function Is_Defaulted (Param : Entity_Id) return Boolean is 6328 Assoc : Node_Id; 6329 6330 begin 6331 Assoc := 6332 First (Generic_Associations (Parent 6333 (Associated_Formal_Package (Actual_Pack)))); 6334 6335 while Present (Assoc) loop 6336 if Nkind (Assoc) = N_Others_Choice then 6337 return True; 6338 6339 elsif Nkind (Assoc) = N_Generic_Association 6340 and then Chars (Selector_Name (Assoc)) = Chars (Param) 6341 then 6342 return Box_Present (Assoc); 6343 end if; 6344 6345 Next (Assoc); 6346 end loop; 6347 6348 return False; 6349 end Is_Defaulted; 6350 6351 -------------------------------- 6352 -- Same_Instantiated_Constant -- 6353 -------------------------------- 6354 6355 function Same_Instantiated_Constant 6356 (E1, E2 : Entity_Id) return Boolean 6357 is 6358 Ent : Entity_Id; 6359 6360 begin 6361 Ent := E2; 6362 while Present (Ent) loop 6363 if E1 = Ent then 6364 return True; 6365 6366 elsif Ekind (Ent) /= E_Constant then 6367 return False; 6368 6369 elsif Is_Entity_Name (Constant_Value (Ent)) then 6370 if Entity (Constant_Value (Ent)) = E1 then 6371 return True; 6372 else 6373 Ent := Entity (Constant_Value (Ent)); 6374 end if; 6375 6376 -- The actual may be a constant that has been folded. Recover 6377 -- original name. 6378 6379 elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then 6380 Ent := Entity (Original_Node (Constant_Value (Ent))); 6381 6382 else 6383 return False; 6384 end if; 6385 end loop; 6386 6387 return False; 6388 end Same_Instantiated_Constant; 6389 6390 -------------------------------- 6391 -- Same_Instantiated_Function -- 6392 -------------------------------- 6393 6394 function Same_Instantiated_Function 6395 (E1, E2 : Entity_Id) return Boolean 6396 is 6397 U1, U2 : Node_Id; 6398 begin 6399 if Alias (E1) = Alias (E2) then 6400 return True; 6401 6402 elsif Present (Alias (E2)) then 6403 U1 := Original_Node (Unit_Declaration_Node (E1)); 6404 U2 := Original_Node (Unit_Declaration_Node (Alias (E2))); 6405 6406 return Nkind (U1) = N_Subprogram_Renaming_Declaration 6407 and then Nkind (Name (U1)) = N_Attribute_Reference 6408 6409 and then Nkind (U2) = N_Subprogram_Renaming_Declaration 6410 and then Nkind (Name (U2)) = N_Attribute_Reference 6411 6412 and then 6413 Attribute_Name (Name (U1)) = Attribute_Name (Name (U2)); 6414 else 6415 return False; 6416 end if; 6417 end Same_Instantiated_Function; 6418 6419 -------------------------------- 6420 -- Same_Instantiated_Variable -- 6421 -------------------------------- 6422 6423 function Same_Instantiated_Variable 6424 (E1, E2 : Entity_Id) return Boolean 6425 is 6426 function Original_Entity (E : Entity_Id) return Entity_Id; 6427 -- Follow chain of renamings to the ultimate ancestor 6428 6429 --------------------- 6430 -- Original_Entity -- 6431 --------------------- 6432 6433 function Original_Entity (E : Entity_Id) return Entity_Id is 6434 Orig : Entity_Id; 6435 6436 begin 6437 Orig := E; 6438 while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration 6439 and then Present (Renamed_Object (Orig)) 6440 and then Is_Entity_Name (Renamed_Object (Orig)) 6441 loop 6442 Orig := Entity (Renamed_Object (Orig)); 6443 end loop; 6444 6445 return Orig; 6446 end Original_Entity; 6447 6448 -- Start of processing for Same_Instantiated_Variable 6449 6450 begin 6451 return Ekind (E1) = Ekind (E2) 6452 and then Original_Entity (E1) = Original_Entity (E2); 6453 end Same_Instantiated_Variable; 6454 6455 -- Start of processing for Check_Formal_Package_Instance 6456 6457 begin 6458 Prev_E1 := E1; 6459 while Present (E1) and then Present (E2) loop 6460 exit when Ekind (E1) = E_Package 6461 and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack); 6462 6463 -- If the formal is the renaming of the formal package, this 6464 -- is the end of its formal part, which may occur before the 6465 -- end of the formal part in the actual in the presence of 6466 -- defaulted parameters in the formal package. 6467 6468 exit when Nkind (Parent (E2)) = N_Package_Renaming_Declaration 6469 and then Renamed_Entity (E2) = Scope (E2); 6470 6471 -- The analysis of the actual may generate additional internal 6472 -- entities. If the formal is defaulted, there is no corresponding 6473 -- analysis and the internal entities must be skipped, until we 6474 -- find corresponding entities again. 6475 6476 if Comes_From_Source (E2) 6477 and then not Comes_From_Source (E1) 6478 and then Chars (E1) /= Chars (E2) 6479 then 6480 while Present (E1) and then Chars (E1) /= Chars (E2) loop 6481 Next_Entity (E1); 6482 end loop; 6483 end if; 6484 6485 if No (E1) then 6486 return; 6487 6488 -- Entities may be declared without full declaration, such as 6489 -- itypes and predefined operators (concatenation for arrays, eg). 6490 -- Skip it and keep the formal entity to find a later match for it. 6491 6492 elsif No (Parent (E2)) and then Ekind (E1) /= Ekind (E2) then 6493 E1 := Prev_E1; 6494 goto Next_E; 6495 6496 -- If the formal entity comes from a formal declaration, it was 6497 -- defaulted in the formal package, and no check is needed on it. 6498 6499 elsif Nkind_In (Original_Node (Parent (E2)), 6500 N_Formal_Object_Declaration, 6501 N_Formal_Type_Declaration) 6502 then 6503 -- If the formal is a tagged type the corresponding class-wide 6504 -- type has been generated as well, and it must be skipped. 6505 6506 if Is_Type (E2) and then Is_Tagged_Type (E2) then 6507 Next_Entity (E2); 6508 end if; 6509 6510 goto Next_E; 6511 6512 -- Ditto for defaulted formal subprograms. 6513 6514 elsif Is_Overloadable (E1) 6515 and then Nkind (Unit_Declaration_Node (E2)) in 6516 N_Formal_Subprogram_Declaration 6517 then 6518 goto Next_E; 6519 6520 elsif Is_Defaulted (E1) then 6521 goto Next_E; 6522 6523 elsif Is_Type (E1) then 6524 6525 -- Subtypes must statically match. E1, E2 are the local entities 6526 -- that are subtypes of the actuals. Itypes generated for other 6527 -- parameters need not be checked, the check will be performed 6528 -- on the parameters themselves. 6529 6530 -- If E2 is a formal type declaration, it is a defaulted parameter 6531 -- and needs no checking. 6532 6533 if not Is_Itype (E1) and then not Is_Itype (E2) then 6534 Check_Mismatch 6535 (not Is_Type (E2) 6536 or else Etype (E1) /= Etype (E2) 6537 or else not Subtypes_Statically_Match (E1, E2)); 6538 end if; 6539 6540 elsif Ekind (E1) = E_Constant then 6541 6542 -- IN parameters must denote the same static value, or the same 6543 -- constant, or the literal null. 6544 6545 Expr1 := Expression (Parent (E1)); 6546 6547 if Ekind (E2) /= E_Constant then 6548 Check_Mismatch (True); 6549 goto Next_E; 6550 else 6551 Expr2 := Expression (Parent (E2)); 6552 end if; 6553 6554 if Is_OK_Static_Expression (Expr1) then 6555 if not Is_OK_Static_Expression (Expr2) then 6556 Check_Mismatch (True); 6557 6558 elsif Is_Discrete_Type (Etype (E1)) then 6559 declare 6560 V1 : constant Uint := Expr_Value (Expr1); 6561 V2 : constant Uint := Expr_Value (Expr2); 6562 begin 6563 Check_Mismatch (V1 /= V2); 6564 end; 6565 6566 elsif Is_Real_Type (Etype (E1)) then 6567 declare 6568 V1 : constant Ureal := Expr_Value_R (Expr1); 6569 V2 : constant Ureal := Expr_Value_R (Expr2); 6570 begin 6571 Check_Mismatch (V1 /= V2); 6572 end; 6573 6574 elsif Is_String_Type (Etype (E1)) 6575 and then Nkind (Expr1) = N_String_Literal 6576 then 6577 if Nkind (Expr2) /= N_String_Literal then 6578 Check_Mismatch (True); 6579 else 6580 Check_Mismatch 6581 (not String_Equal (Strval (Expr1), Strval (Expr2))); 6582 end if; 6583 end if; 6584 6585 elsif Is_Entity_Name (Expr1) then 6586 if Is_Entity_Name (Expr2) then 6587 if Entity (Expr1) = Entity (Expr2) then 6588 null; 6589 else 6590 Check_Mismatch 6591 (not Same_Instantiated_Constant 6592 (Entity (Expr1), Entity (Expr2))); 6593 end if; 6594 6595 else 6596 Check_Mismatch (True); 6597 end if; 6598 6599 elsif Is_Entity_Name (Original_Node (Expr1)) 6600 and then Is_Entity_Name (Expr2) 6601 and then Same_Instantiated_Constant 6602 (Entity (Original_Node (Expr1)), Entity (Expr2)) 6603 then 6604 null; 6605 6606 elsif Nkind (Expr1) = N_Null then 6607 Check_Mismatch (Nkind (Expr1) /= N_Null); 6608 6609 else 6610 Check_Mismatch (True); 6611 end if; 6612 6613 elsif Ekind (E1) = E_Variable then 6614 Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); 6615 6616 elsif Ekind (E1) = E_Package then 6617 Check_Mismatch 6618 (Ekind (E1) /= Ekind (E2) 6619 or else (Present (Renamed_Object (E2)) 6620 and then Renamed_Object (E1) /= 6621 Renamed_Object (E2))); 6622 6623 elsif Is_Overloadable (E1) then 6624 -- Verify that the actual subprograms match. Note that actuals 6625 -- that are attributes are rewritten as subprograms. If the 6626 -- subprogram in the formal package is defaulted, no check is 6627 -- needed. Note that this can only happen in Ada 2005 when the 6628 -- formal package can be partially parameterized. 6629 6630 if Nkind (Unit_Declaration_Node (E1)) = 6631 N_Subprogram_Renaming_Declaration 6632 and then From_Default (Unit_Declaration_Node (E1)) 6633 then 6634 null; 6635 6636 -- If the formal package has an "others" box association that 6637 -- covers this formal, there is no need for a check either. 6638 6639 elsif Nkind (Unit_Declaration_Node (E2)) in 6640 N_Formal_Subprogram_Declaration 6641 and then Box_Present (Unit_Declaration_Node (E2)) 6642 then 6643 null; 6644 6645 -- No check needed if subprogram is a defaulted null procedure 6646 6647 elsif No (Alias (E2)) 6648 and then Ekind (E2) = E_Procedure 6649 and then 6650 Null_Present (Specification (Unit_Declaration_Node (E2))) 6651 then 6652 null; 6653 6654 -- Otherwise the actual in the formal and the actual in the 6655 -- instantiation of the formal must match, up to renamings. 6656 6657 else 6658 Check_Mismatch 6659 (Ekind (E2) /= Ekind (E1) 6660 or else not Same_Instantiated_Function (E1, E2)); 6661 end if; 6662 6663 else 6664 raise Program_Error; 6665 end if; 6666 6667 <<Next_E>> 6668 Prev_E1 := E1; 6669 Next_Entity (E1); 6670 Next_Entity (E2); 6671 end loop; 6672 end Check_Formal_Package_Instance; 6673 6674 --------------------------- 6675 -- Check_Formal_Packages -- 6676 --------------------------- 6677 6678 procedure Check_Formal_Packages (P_Id : Entity_Id) is 6679 E : Entity_Id; 6680 Formal_P : Entity_Id; 6681 Formal_Decl : Node_Id; 6682 begin 6683 -- Iterate through the declarations in the instance, looking for package 6684 -- renaming declarations that denote instances of formal packages. Stop 6685 -- when we find the renaming of the current package itself. The 6686 -- declaration for a formal package without a box is followed by an 6687 -- internal entity that repeats the instantiation. 6688 6689 E := First_Entity (P_Id); 6690 while Present (E) loop 6691 if Ekind (E) = E_Package then 6692 if Renamed_Object (E) = P_Id then 6693 exit; 6694 6695 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6696 null; 6697 6698 else 6699 Formal_Decl := Parent (Associated_Formal_Package (E)); 6700 6701 -- Nothing to check if the formal has a box or an others_clause 6702 -- (necessarily with a box), or no associations altogether 6703 6704 if Box_Present (Formal_Decl) 6705 or else No (Generic_Associations (Formal_Decl)) 6706 then 6707 null; 6708 6709 elsif Nkind (First (Generic_Associations (Formal_Decl))) = 6710 N_Others_Choice 6711 then 6712 -- The internal validating package was generated but formal 6713 -- and instance are known to be compatible. 6714 6715 Formal_P := Next_Entity (E); 6716 Remove (Unit_Declaration_Node (Formal_P)); 6717 6718 else 6719 Formal_P := Next_Entity (E); 6720 6721 -- If the instance is within an enclosing instance body 6722 -- there is no need to verify the legality of current formal 6723 -- packages because they were legal in the generic body. 6724 -- This optimization may be applicable elsewhere, and it 6725 -- also removes spurious errors that may arise with 6726 -- on-the-fly inlining and confusion between private and 6727 -- full views. 6728 6729 if not In_Instance_Body then 6730 Check_Formal_Package_Instance (Formal_P, E); 6731 end if; 6732 6733 -- Restore the visibility of formals of the formal instance 6734 -- that are not defaulted, and are hidden within the current 6735 -- generic. These formals may be visible within an enclosing 6736 -- generic. 6737 6738 declare 6739 Elmt : Elmt_Id; 6740 begin 6741 Elmt := First_Elmt (Hidden_In_Formal_Instance (Formal_P)); 6742 while Present (Elmt) loop 6743 Set_Is_Hidden (Node (Elmt), False); 6744 Next_Elmt (Elmt); 6745 end loop; 6746 end; 6747 6748 -- After checking, remove the internal validating package. 6749 -- It is only needed for semantic checks, and as it may 6750 -- contain generic formal declarations it should not reach 6751 -- gigi. 6752 6753 Remove (Unit_Declaration_Node (Formal_P)); 6754 end if; 6755 end if; 6756 end if; 6757 6758 Next_Entity (E); 6759 end loop; 6760 end Check_Formal_Packages; 6761 6762 --------------------------------- 6763 -- Check_Forward_Instantiation -- 6764 --------------------------------- 6765 6766 procedure Check_Forward_Instantiation (Decl : Node_Id) is 6767 S : Entity_Id; 6768 Gen_Comp : Entity_Id := Cunit_Entity (Get_Source_Unit (Decl)); 6769 6770 begin 6771 -- The instantiation appears before the generic body if we are in the 6772 -- scope of the unit containing the generic, either in its spec or in 6773 -- the package body, and before the generic body. 6774 6775 if Ekind (Gen_Comp) = E_Package_Body then 6776 Gen_Comp := Spec_Entity (Gen_Comp); 6777 end if; 6778 6779 if In_Open_Scopes (Gen_Comp) 6780 and then No (Corresponding_Body (Decl)) 6781 then 6782 S := Current_Scope; 6783 6784 while Present (S) 6785 and then not Is_Compilation_Unit (S) 6786 and then not Is_Child_Unit (S) 6787 loop 6788 if Ekind (S) = E_Package then 6789 Set_Has_Forward_Instantiation (S); 6790 end if; 6791 6792 S := Scope (S); 6793 end loop; 6794 end if; 6795 end Check_Forward_Instantiation; 6796 6797 --------------------------- 6798 -- Check_Generic_Actuals -- 6799 --------------------------- 6800 6801 -- The visibility of the actuals may be different between the point of 6802 -- generic instantiation and the instantiation of the body. 6803 6804 procedure Check_Generic_Actuals 6805 (Instance : Entity_Id; 6806 Is_Formal_Box : Boolean) 6807 is 6808 E : Entity_Id; 6809 Astype : Entity_Id; 6810 6811 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean; 6812 -- For a formal that is an array type, the component type is often a 6813 -- previous formal in the same unit. The privacy status of the component 6814 -- type will have been examined earlier in the traversal of the 6815 -- corresponding actuals, and this status should not be modified for 6816 -- the array (sub)type itself. However, if the base type of the array 6817 -- (sub)type is private, its full view must be restored in the body to 6818 -- be consistent with subsequent index subtypes, etc. 6819 -- 6820 -- To detect this case we have to rescan the list of formals, which is 6821 -- usually short enough to ignore the resulting inefficiency. 6822 6823 ----------------------------- 6824 -- Denotes_Previous_Actual -- 6825 ----------------------------- 6826 6827 function Denotes_Previous_Actual (Typ : Entity_Id) return Boolean is 6828 Prev : Entity_Id; 6829 6830 begin 6831 Prev := First_Entity (Instance); 6832 while Present (Prev) loop 6833 if Is_Type (Prev) 6834 and then Nkind (Parent (Prev)) = N_Subtype_Declaration 6835 and then Is_Entity_Name (Subtype_Indication (Parent (Prev))) 6836 and then Entity (Subtype_Indication (Parent (Prev))) = Typ 6837 then 6838 return True; 6839 6840 elsif Prev = E then 6841 return False; 6842 6843 else 6844 Next_Entity (Prev); 6845 end if; 6846 end loop; 6847 6848 return False; 6849 end Denotes_Previous_Actual; 6850 6851 -- Start of processing for Check_Generic_Actuals 6852 6853 begin 6854 E := First_Entity (Instance); 6855 while Present (E) loop 6856 if Is_Type (E) 6857 and then Nkind (Parent (E)) = N_Subtype_Declaration 6858 and then Scope (Etype (E)) /= Instance 6859 and then Is_Entity_Name (Subtype_Indication (Parent (E))) 6860 then 6861 if Is_Array_Type (E) 6862 and then not Is_Private_Type (Etype (E)) 6863 and then Denotes_Previous_Actual (Component_Type (E)) 6864 then 6865 null; 6866 else 6867 Check_Private_View (Subtype_Indication (Parent (E))); 6868 end if; 6869 6870 Set_Is_Generic_Actual_Type (E); 6871 6872 if Is_Private_Type (E) and then Present (Full_View (E)) then 6873 Set_Is_Generic_Actual_Type (Full_View (E)); 6874 end if; 6875 6876 Set_Is_Hidden (E, False); 6877 Set_Is_Potentially_Use_Visible (E, In_Use (Instance)); 6878 6879 -- We constructed the generic actual type as a subtype of the 6880 -- supplied type. This means that it normally would not inherit 6881 -- subtype specific attributes of the actual, which is wrong for 6882 -- the generic case. 6883 6884 Astype := Ancestor_Subtype (E); 6885 6886 if No (Astype) then 6887 6888 -- This can happen when E is an itype that is the full view of 6889 -- a private type completed, e.g. with a constrained array. In 6890 -- that case, use the first subtype, which will carry size 6891 -- information. The base type itself is unconstrained and will 6892 -- not carry it. 6893 6894 Astype := First_Subtype (E); 6895 end if; 6896 6897 Set_Size_Info (E, (Astype)); 6898 Set_RM_Size (E, RM_Size (Astype)); 6899 Set_First_Rep_Item (E, First_Rep_Item (Astype)); 6900 6901 if Is_Discrete_Or_Fixed_Point_Type (E) then 6902 Set_RM_Size (E, RM_Size (Astype)); 6903 6904 -- In nested instances, the base type of an access actual may 6905 -- itself be private, and need to be exchanged. 6906 6907 elsif Is_Access_Type (E) 6908 and then Is_Private_Type (Etype (E)) 6909 then 6910 Check_Private_View 6911 (New_Occurrence_Of (Etype (E), Sloc (Instance))); 6912 end if; 6913 6914 elsif Ekind (E) = E_Package then 6915 6916 -- If this is the renaming for the current instance, we're done. 6917 -- Otherwise it is a formal package. If the corresponding formal 6918 -- was declared with a box, the (instantiations of the) generic 6919 -- formal part are also visible. Otherwise, ignore the entity 6920 -- created to validate the actuals. 6921 6922 if Renamed_Object (E) = Instance then 6923 exit; 6924 6925 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 6926 null; 6927 6928 -- The visibility of a formal of an enclosing generic is already 6929 -- correct. 6930 6931 elsif Denotes_Formal_Package (E) then 6932 null; 6933 6934 elsif Present (Associated_Formal_Package (E)) 6935 and then not Is_Generic_Formal (E) 6936 then 6937 if Box_Present (Parent (Associated_Formal_Package (E))) then 6938 Check_Generic_Actuals (Renamed_Object (E), True); 6939 6940 else 6941 Check_Generic_Actuals (Renamed_Object (E), False); 6942 end if; 6943 6944 Set_Is_Hidden (E, False); 6945 end if; 6946 6947 -- If this is a subprogram instance (in a wrapper package) the 6948 -- actual is fully visible. 6949 6950 elsif Is_Wrapper_Package (Instance) then 6951 Set_Is_Hidden (E, False); 6952 6953 -- If the formal package is declared with a box, or if the formal 6954 -- parameter is defaulted, it is visible in the body. 6955 6956 elsif Is_Formal_Box or else Is_Visible_Formal (E) then 6957 Set_Is_Hidden (E, False); 6958 end if; 6959 6960 if Ekind (E) = E_Constant then 6961 6962 -- If the type of the actual is a private type declared in the 6963 -- enclosing scope of the generic unit, the body of the generic 6964 -- sees the full view of the type (because it has to appear in 6965 -- the corresponding package body). If the type is private now, 6966 -- exchange views to restore the proper visiblity in the instance. 6967 6968 declare 6969 Typ : constant Entity_Id := Base_Type (Etype (E)); 6970 -- The type of the actual 6971 6972 Gen_Id : Entity_Id; 6973 -- The generic unit 6974 6975 Parent_Scope : Entity_Id; 6976 -- The enclosing scope of the generic unit 6977 6978 begin 6979 if Is_Wrapper_Package (Instance) then 6980 Gen_Id := 6981 Generic_Parent 6982 (Specification 6983 (Unit_Declaration_Node 6984 (Related_Instance (Instance)))); 6985 else 6986 Gen_Id := 6987 Generic_Parent (Package_Specification (Instance)); 6988 end if; 6989 6990 Parent_Scope := Scope (Gen_Id); 6991 6992 -- The exchange is only needed if the generic is defined 6993 -- within a package which is not a common ancestor of the 6994 -- scope of the instance, and is not already in scope. 6995 6996 if Is_Private_Type (Typ) 6997 and then Scope (Typ) = Parent_Scope 6998 and then Scope (Instance) /= Parent_Scope 6999 and then Ekind (Parent_Scope) = E_Package 7000 and then not Is_Child_Unit (Gen_Id) 7001 then 7002 Switch_View (Typ); 7003 7004 -- If the type of the entity is a subtype, it may also have 7005 -- to be made visible, together with the base type of its 7006 -- full view, after exchange. 7007 7008 if Is_Private_Type (Etype (E)) then 7009 Switch_View (Etype (E)); 7010 Switch_View (Base_Type (Etype (E))); 7011 end if; 7012 end if; 7013 end; 7014 end if; 7015 7016 Next_Entity (E); 7017 end loop; 7018 end Check_Generic_Actuals; 7019 7020 ------------------------------ 7021 -- Check_Generic_Child_Unit -- 7022 ------------------------------ 7023 7024 procedure Check_Generic_Child_Unit 7025 (Gen_Id : Node_Id; 7026 Parent_Installed : in out Boolean) 7027 is 7028 Loc : constant Source_Ptr := Sloc (Gen_Id); 7029 Gen_Par : Entity_Id := Empty; 7030 E : Entity_Id; 7031 Inst_Par : Entity_Id; 7032 S : Node_Id; 7033 7034 function Find_Generic_Child 7035 (Scop : Entity_Id; 7036 Id : Node_Id) return Entity_Id; 7037 -- Search generic parent for possible child unit with the given name 7038 7039 function In_Enclosing_Instance return Boolean; 7040 -- Within an instance of the parent, the child unit may be denoted by 7041 -- a simple name, or an abbreviated expanded name. Examine enclosing 7042 -- scopes to locate a possible parent instantiation. 7043 7044 ------------------------ 7045 -- Find_Generic_Child -- 7046 ------------------------ 7047 7048 function Find_Generic_Child 7049 (Scop : Entity_Id; 7050 Id : Node_Id) return Entity_Id 7051 is 7052 E : Entity_Id; 7053 7054 begin 7055 -- If entity of name is already set, instance has already been 7056 -- resolved, e.g. in an enclosing instantiation. 7057 7058 if Present (Entity (Id)) then 7059 if Scope (Entity (Id)) = Scop then 7060 return Entity (Id); 7061 else 7062 return Empty; 7063 end if; 7064 7065 else 7066 E := First_Entity (Scop); 7067 while Present (E) loop 7068 if Chars (E) = Chars (Id) 7069 and then Is_Child_Unit (E) 7070 then 7071 if Is_Child_Unit (E) 7072 and then not Is_Visible_Lib_Unit (E) 7073 then 7074 Error_Msg_NE 7075 ("generic child unit& is not visible", Gen_Id, E); 7076 end if; 7077 7078 Set_Entity (Id, E); 7079 return E; 7080 end if; 7081 7082 Next_Entity (E); 7083 end loop; 7084 7085 return Empty; 7086 end if; 7087 end Find_Generic_Child; 7088 7089 --------------------------- 7090 -- In_Enclosing_Instance -- 7091 --------------------------- 7092 7093 function In_Enclosing_Instance return Boolean is 7094 Enclosing_Instance : Node_Id; 7095 Instance_Decl : Node_Id; 7096 7097 begin 7098 -- We do not inline any call that contains instantiations, except 7099 -- for instantiations of Unchecked_Conversion, so if we are within 7100 -- an inlined body the current instance does not require parents. 7101 7102 if In_Inlined_Body then 7103 pragma Assert (Chars (Gen_Id) = Name_Unchecked_Conversion); 7104 return False; 7105 end if; 7106 7107 -- Loop to check enclosing scopes 7108 7109 Enclosing_Instance := Current_Scope; 7110 while Present (Enclosing_Instance) loop 7111 Instance_Decl := Unit_Declaration_Node (Enclosing_Instance); 7112 7113 if Ekind (Enclosing_Instance) = E_Package 7114 and then Is_Generic_Instance (Enclosing_Instance) 7115 and then Present 7116 (Generic_Parent (Specification (Instance_Decl))) 7117 then 7118 -- Check whether the generic we are looking for is a child of 7119 -- this instance. 7120 7121 E := Find_Generic_Child 7122 (Generic_Parent (Specification (Instance_Decl)), Gen_Id); 7123 exit when Present (E); 7124 7125 else 7126 E := Empty; 7127 end if; 7128 7129 Enclosing_Instance := Scope (Enclosing_Instance); 7130 end loop; 7131 7132 if No (E) then 7133 7134 -- Not a child unit 7135 7136 Analyze (Gen_Id); 7137 return False; 7138 7139 else 7140 Rewrite (Gen_Id, 7141 Make_Expanded_Name (Loc, 7142 Chars => Chars (E), 7143 Prefix => New_Occurrence_Of (Enclosing_Instance, Loc), 7144 Selector_Name => New_Occurrence_Of (E, Loc))); 7145 7146 Set_Entity (Gen_Id, E); 7147 Set_Etype (Gen_Id, Etype (E)); 7148 Parent_Installed := False; -- Already in scope. 7149 return True; 7150 end if; 7151 end In_Enclosing_Instance; 7152 7153 -- Start of processing for Check_Generic_Child_Unit 7154 7155 begin 7156 -- If the name of the generic is given by a selected component, it may 7157 -- be the name of a generic child unit, and the prefix is the name of an 7158 -- instance of the parent, in which case the child unit must be visible. 7159 -- If this instance is not in scope, it must be placed there and removed 7160 -- after instantiation, because what is being instantiated is not the 7161 -- original child, but the corresponding child present in the instance 7162 -- of the parent. 7163 7164 -- If the child is instantiated within the parent, it can be given by 7165 -- a simple name. In this case the instance is already in scope, but 7166 -- the child generic must be recovered from the generic parent as well. 7167 7168 if Nkind (Gen_Id) = N_Selected_Component then 7169 S := Selector_Name (Gen_Id); 7170 Analyze (Prefix (Gen_Id)); 7171 Inst_Par := Entity (Prefix (Gen_Id)); 7172 7173 if Ekind (Inst_Par) = E_Package 7174 and then Present (Renamed_Object (Inst_Par)) 7175 then 7176 Inst_Par := Renamed_Object (Inst_Par); 7177 end if; 7178 7179 if Ekind (Inst_Par) = E_Package then 7180 if Nkind (Parent (Inst_Par)) = N_Package_Specification then 7181 Gen_Par := Generic_Parent (Parent (Inst_Par)); 7182 7183 elsif Nkind (Parent (Inst_Par)) = N_Defining_Program_Unit_Name 7184 and then 7185 Nkind (Parent (Parent (Inst_Par))) = N_Package_Specification 7186 then 7187 Gen_Par := Generic_Parent (Parent (Parent (Inst_Par))); 7188 end if; 7189 7190 elsif Ekind (Inst_Par) = E_Generic_Package 7191 and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration 7192 then 7193 -- A formal package may be a real child package, and not the 7194 -- implicit instance within a parent. In this case the child is 7195 -- not visible and has to be retrieved explicitly as well. 7196 7197 Gen_Par := Inst_Par; 7198 end if; 7199 7200 if Present (Gen_Par) then 7201 7202 -- The prefix denotes an instantiation. The entity itself may be a 7203 -- nested generic, or a child unit. 7204 7205 E := Find_Generic_Child (Gen_Par, S); 7206 7207 if Present (E) then 7208 Change_Selected_Component_To_Expanded_Name (Gen_Id); 7209 Set_Entity (Gen_Id, E); 7210 Set_Etype (Gen_Id, Etype (E)); 7211 Set_Entity (S, E); 7212 Set_Etype (S, Etype (E)); 7213 7214 -- Indicate that this is a reference to the parent 7215 7216 if In_Extended_Main_Source_Unit (Gen_Id) then 7217 Set_Is_Instantiated (Inst_Par); 7218 end if; 7219 7220 -- A common mistake is to replicate the naming scheme of a 7221 -- hierarchy by instantiating a generic child directly, rather 7222 -- than the implicit child in a parent instance: 7223 7224 -- generic .. package Gpar is .. 7225 -- generic .. package Gpar.Child is .. 7226 -- package Par is new Gpar (); 7227 7228 -- with Gpar.Child; 7229 -- package Par.Child is new Gpar.Child (); 7230 -- rather than Par.Child 7231 7232 -- In this case the instantiation is within Par, which is an 7233 -- instance, but Gpar does not denote Par because we are not IN 7234 -- the instance of Gpar, so this is illegal. The test below 7235 -- recognizes this particular case. 7236 7237 if Is_Child_Unit (E) 7238 and then not Comes_From_Source (Entity (Prefix (Gen_Id))) 7239 and then (not In_Instance 7240 or else Nkind (Parent (Parent (Gen_Id))) = 7241 N_Compilation_Unit) 7242 then 7243 Error_Msg_N 7244 ("prefix of generic child unit must be instance of parent", 7245 Gen_Id); 7246 end if; 7247 7248 if not In_Open_Scopes (Inst_Par) 7249 and then Nkind (Parent (Gen_Id)) not in 7250 N_Generic_Renaming_Declaration 7251 then 7252 Install_Parent (Inst_Par); 7253 Parent_Installed := True; 7254 7255 elsif In_Open_Scopes (Inst_Par) then 7256 7257 -- If the parent is already installed, install the actuals 7258 -- for its formal packages. This is necessary when the child 7259 -- instance is a child of the parent instance: in this case, 7260 -- the parent is placed on the scope stack but the formal 7261 -- packages are not made visible. 7262 7263 Install_Formal_Packages (Inst_Par); 7264 end if; 7265 7266 else 7267 -- If the generic parent does not contain an entity that 7268 -- corresponds to the selector, the instance doesn't either. 7269 -- Analyzing the node will yield the appropriate error message. 7270 -- If the entity is not a child unit, then it is an inner 7271 -- generic in the parent. 7272 7273 Analyze (Gen_Id); 7274 end if; 7275 7276 else 7277 Analyze (Gen_Id); 7278 7279 if Is_Child_Unit (Entity (Gen_Id)) 7280 and then 7281 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7282 and then not In_Open_Scopes (Inst_Par) 7283 then 7284 Install_Parent (Inst_Par); 7285 Parent_Installed := True; 7286 7287 -- The generic unit may be the renaming of the implicit child 7288 -- present in an instance. In that case the parent instance is 7289 -- obtained from the name of the renamed entity. 7290 7291 elsif Ekind (Entity (Gen_Id)) = E_Generic_Package 7292 and then Present (Renamed_Entity (Entity (Gen_Id))) 7293 and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id))) 7294 then 7295 declare 7296 Renamed_Package : constant Node_Id := 7297 Name (Parent (Entity (Gen_Id))); 7298 begin 7299 if Nkind (Renamed_Package) = N_Expanded_Name then 7300 Inst_Par := Entity (Prefix (Renamed_Package)); 7301 Install_Parent (Inst_Par); 7302 Parent_Installed := True; 7303 end if; 7304 end; 7305 end if; 7306 end if; 7307 7308 elsif Nkind (Gen_Id) = N_Expanded_Name then 7309 7310 -- Entity already present, analyze prefix, whose meaning may be an 7311 -- instance in the current context. If it is an instance of a 7312 -- relative within another, the proper parent may still have to be 7313 -- installed, if they are not of the same generation. 7314 7315 Analyze (Prefix (Gen_Id)); 7316 7317 -- Prevent cascaded errors 7318 7319 if Etype (Prefix (Gen_Id)) = Any_Type then 7320 return; 7321 end if; 7322 7323 -- In the unlikely case that a local declaration hides the name of 7324 -- the parent package, locate it on the homonym chain. If the context 7325 -- is an instance of the parent, the renaming entity is flagged as 7326 -- such. 7327 7328 Inst_Par := Entity (Prefix (Gen_Id)); 7329 while Present (Inst_Par) 7330 and then not Is_Package_Or_Generic_Package (Inst_Par) 7331 loop 7332 Inst_Par := Homonym (Inst_Par); 7333 end loop; 7334 7335 pragma Assert (Present (Inst_Par)); 7336 Set_Entity (Prefix (Gen_Id), Inst_Par); 7337 7338 if In_Enclosing_Instance then 7339 null; 7340 7341 elsif Present (Entity (Gen_Id)) 7342 and then Is_Child_Unit (Entity (Gen_Id)) 7343 and then not In_Open_Scopes (Inst_Par) 7344 then 7345 Install_Parent (Inst_Par); 7346 Parent_Installed := True; 7347 end if; 7348 7349 elsif In_Enclosing_Instance then 7350 7351 -- The child unit is found in some enclosing scope 7352 7353 null; 7354 7355 else 7356 Analyze (Gen_Id); 7357 7358 -- If this is the renaming of the implicit child in a parent 7359 -- instance, recover the parent name and install it. 7360 7361 if Is_Entity_Name (Gen_Id) then 7362 E := Entity (Gen_Id); 7363 7364 if Is_Generic_Unit (E) 7365 and then Nkind (Parent (E)) in N_Generic_Renaming_Declaration 7366 and then Is_Child_Unit (Renamed_Object (E)) 7367 and then Is_Generic_Unit (Scope (Renamed_Object (E))) 7368 and then Nkind (Name (Parent (E))) = N_Expanded_Name 7369 then 7370 Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E)))); 7371 Inst_Par := Entity (Prefix (Gen_Id)); 7372 7373 if not In_Open_Scopes (Inst_Par) then 7374 Install_Parent (Inst_Par); 7375 Parent_Installed := True; 7376 end if; 7377 7378 -- If it is a child unit of a non-generic parent, it may be 7379 -- use-visible and given by a direct name. Install parent as 7380 -- for other cases. 7381 7382 elsif Is_Generic_Unit (E) 7383 and then Is_Child_Unit (E) 7384 and then 7385 Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration 7386 and then not Is_Generic_Unit (Scope (E)) 7387 then 7388 if not In_Open_Scopes (Scope (E)) then 7389 Install_Parent (Scope (E)); 7390 Parent_Installed := True; 7391 end if; 7392 end if; 7393 end if; 7394 end if; 7395 end Check_Generic_Child_Unit; 7396 7397 ----------------------------- 7398 -- Check_Hidden_Child_Unit -- 7399 ----------------------------- 7400 7401 procedure Check_Hidden_Child_Unit 7402 (N : Node_Id; 7403 Gen_Unit : Entity_Id; 7404 Act_Decl_Id : Entity_Id) 7405 is 7406 Gen_Id : constant Node_Id := Name (N); 7407 7408 begin 7409 if Is_Child_Unit (Gen_Unit) 7410 and then Is_Child_Unit (Act_Decl_Id) 7411 and then Nkind (Gen_Id) = N_Expanded_Name 7412 and then Entity (Prefix (Gen_Id)) = Scope (Act_Decl_Id) 7413 and then Chars (Gen_Unit) = Chars (Act_Decl_Id) 7414 then 7415 Error_Msg_Node_2 := Scope (Act_Decl_Id); 7416 Error_Msg_NE 7417 ("generic unit & is implicitly declared in &", 7418 Defining_Unit_Name (N), Gen_Unit); 7419 Error_Msg_N ("\instance must have different name", 7420 Defining_Unit_Name (N)); 7421 end if; 7422 end Check_Hidden_Child_Unit; 7423 7424 ------------------------ 7425 -- Check_Private_View -- 7426 ------------------------ 7427 7428 procedure Check_Private_View (N : Node_Id) is 7429 T : constant Entity_Id := Etype (N); 7430 BT : Entity_Id; 7431 7432 begin 7433 -- Exchange views if the type was not private in the generic but is 7434 -- private at the point of instantiation. Do not exchange views if 7435 -- the scope of the type is in scope. This can happen if both generic 7436 -- and instance are sibling units, or if type is defined in a parent. 7437 -- In this case the visibility of the type will be correct for all 7438 -- semantic checks. 7439 7440 if Present (T) then 7441 BT := Base_Type (T); 7442 7443 if Is_Private_Type (T) 7444 and then not Has_Private_View (N) 7445 and then Present (Full_View (T)) 7446 and then not In_Open_Scopes (Scope (T)) 7447 then 7448 -- In the generic, the full type was visible. Save the private 7449 -- entity, for subsequent exchange. 7450 7451 Switch_View (T); 7452 7453 elsif Has_Private_View (N) 7454 and then not Is_Private_Type (T) 7455 and then not Has_Been_Exchanged (T) 7456 and then Etype (Get_Associated_Node (N)) /= T 7457 then 7458 -- Only the private declaration was visible in the generic. If 7459 -- the type appears in a subtype declaration, the subtype in the 7460 -- instance must have a view compatible with that of its parent, 7461 -- which must be exchanged (see corresponding code in Restore_ 7462 -- Private_Views). Otherwise, if the type is defined in a parent 7463 -- unit, leave full visibility within instance, which is safe. 7464 7465 if In_Open_Scopes (Scope (Base_Type (T))) 7466 and then not Is_Private_Type (Base_Type (T)) 7467 and then Comes_From_Source (Base_Type (T)) 7468 then 7469 null; 7470 7471 elsif Nkind (Parent (N)) = N_Subtype_Declaration 7472 or else not In_Private_Part (Scope (Base_Type (T))) 7473 then 7474 Prepend_Elmt (T, Exchanged_Views); 7475 Exchange_Declarations (Etype (Get_Associated_Node (N))); 7476 end if; 7477 7478 -- For composite types with inconsistent representation exchange 7479 -- component types accordingly. 7480 7481 elsif Is_Access_Type (T) 7482 and then Is_Private_Type (Designated_Type (T)) 7483 and then not Has_Private_View (N) 7484 and then Present (Full_View (Designated_Type (T))) 7485 then 7486 Switch_View (Designated_Type (T)); 7487 7488 elsif Is_Array_Type (T) then 7489 if Is_Private_Type (Component_Type (T)) 7490 and then not Has_Private_View (N) 7491 and then Present (Full_View (Component_Type (T))) 7492 then 7493 Switch_View (Component_Type (T)); 7494 end if; 7495 7496 -- The normal exchange mechanism relies on the setting of a 7497 -- flag on the reference in the generic. However, an additional 7498 -- mechanism is needed for types that are not explicitly 7499 -- mentioned in the generic, but may be needed in expanded code 7500 -- in the instance. This includes component types of arrays and 7501 -- designated types of access types. This processing must also 7502 -- include the index types of arrays which we take care of here. 7503 7504 declare 7505 Indx : Node_Id; 7506 Typ : Entity_Id; 7507 7508 begin 7509 Indx := First_Index (T); 7510 while Present (Indx) loop 7511 Typ := Base_Type (Etype (Indx)); 7512 7513 if Is_Private_Type (Typ) 7514 and then Present (Full_View (Typ)) 7515 then 7516 Switch_View (Typ); 7517 end if; 7518 7519 Next_Index (Indx); 7520 end loop; 7521 end; 7522 7523 -- The following case does not test Has_Private_View (N) so it may 7524 -- end up switching views when they are not supposed to be switched. 7525 -- This might be in keeping with Set_Global_Type setting the flag 7526 -- for an array type even if it is not private ??? 7527 7528 elsif Is_Private_Type (T) 7529 and then Present (Full_View (T)) 7530 and then Is_Array_Type (Full_View (T)) 7531 and then Is_Private_Type (Component_Type (Full_View (T))) 7532 then 7533 Switch_View (T); 7534 7535 -- Finally, a non-private subtype may have a private base type, which 7536 -- must be exchanged for consistency. This can happen when a package 7537 -- body is instantiated, when the scope stack is empty but in fact 7538 -- the subtype and the base type are declared in an enclosing scope. 7539 7540 -- Note that in this case we introduce an inconsistency in the view 7541 -- set, because we switch the base type BT, but there could be some 7542 -- private dependent subtypes of BT which remain unswitched. Such 7543 -- subtypes might need to be switched at a later point (see specific 7544 -- provision for that case in Switch_View). 7545 7546 elsif not Is_Private_Type (T) 7547 and then not Has_Private_View (N) 7548 and then Is_Private_Type (BT) 7549 and then Present (Full_View (BT)) 7550 and then not Is_Generic_Type (BT) 7551 and then not In_Open_Scopes (BT) 7552 then 7553 Prepend_Elmt (Full_View (BT), Exchanged_Views); 7554 Exchange_Declarations (BT); 7555 end if; 7556 end if; 7557 end Check_Private_View; 7558 7559 ----------------------------- 7560 -- Check_Hidden_Primitives -- 7561 ----------------------------- 7562 7563 function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is 7564 Actual : Node_Id; 7565 Gen_T : Entity_Id; 7566 Result : Elist_Id := No_Elist; 7567 7568 begin 7569 if No (Assoc_List) then 7570 return No_Elist; 7571 end if; 7572 7573 -- Traverse the list of associations between formals and actuals 7574 -- searching for renamings of tagged types 7575 7576 Actual := First (Assoc_List); 7577 while Present (Actual) loop 7578 if Nkind (Actual) = N_Subtype_Declaration then 7579 Gen_T := Generic_Parent_Type (Actual); 7580 7581 if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then 7582 7583 -- Traverse the list of primitives of the actual types 7584 -- searching for hidden primitives that are visible in the 7585 -- corresponding generic formal; leave them visible and 7586 -- append them to Result to restore their decoration later. 7587 7588 Install_Hidden_Primitives 7589 (Prims_List => Result, 7590 Gen_T => Gen_T, 7591 Act_T => Entity (Subtype_Indication (Actual))); 7592 end if; 7593 end if; 7594 7595 Next (Actual); 7596 end loop; 7597 7598 return Result; 7599 end Check_Hidden_Primitives; 7600 7601 -------------------------- 7602 -- Contains_Instance_Of -- 7603 -------------------------- 7604 7605 function Contains_Instance_Of 7606 (Inner : Entity_Id; 7607 Outer : Entity_Id; 7608 N : Node_Id) return Boolean 7609 is 7610 Elmt : Elmt_Id; 7611 Scop : Entity_Id; 7612 7613 begin 7614 Scop := Outer; 7615 7616 -- Verify that there are no circular instantiations. We check whether 7617 -- the unit contains an instance of the current scope or some enclosing 7618 -- scope (in case one of the instances appears in a subunit). Longer 7619 -- circularities involving subunits might seem too pathological to 7620 -- consider, but they were not too pathological for the authors of 7621 -- DEC bc30vsq, so we loop over all enclosing scopes, and mark all 7622 -- enclosing generic scopes as containing an instance. 7623 7624 loop 7625 -- Within a generic subprogram body, the scope is not generic, to 7626 -- allow for recursive subprograms. Use the declaration to determine 7627 -- whether this is a generic unit. 7628 7629 if Ekind (Scop) = E_Generic_Package 7630 or else (Is_Subprogram (Scop) 7631 and then Nkind (Unit_Declaration_Node (Scop)) = 7632 N_Generic_Subprogram_Declaration) 7633 then 7634 Elmt := First_Elmt (Inner_Instances (Inner)); 7635 7636 while Present (Elmt) loop 7637 if Node (Elmt) = Scop then 7638 Error_Msg_Node_2 := Inner; 7639 Error_Msg_NE 7640 ("circular Instantiation: & instantiated within &!", 7641 N, Scop); 7642 return True; 7643 7644 elsif Node (Elmt) = Inner then 7645 return True; 7646 7647 elsif Contains_Instance_Of (Node (Elmt), Scop, N) then 7648 Error_Msg_Node_2 := Inner; 7649 Error_Msg_NE 7650 ("circular Instantiation: & instantiated within &!", 7651 N, Node (Elmt)); 7652 return True; 7653 end if; 7654 7655 Next_Elmt (Elmt); 7656 end loop; 7657 7658 -- Indicate that Inner is being instantiated within Scop 7659 7660 Append_Elmt (Inner, Inner_Instances (Scop)); 7661 end if; 7662 7663 if Scop = Standard_Standard then 7664 exit; 7665 else 7666 Scop := Scope (Scop); 7667 end if; 7668 end loop; 7669 7670 return False; 7671 end Contains_Instance_Of; 7672 7673 ----------------------- 7674 -- Copy_Generic_Node -- 7675 ----------------------- 7676 7677 function Copy_Generic_Node 7678 (N : Node_Id; 7679 Parent_Id : Node_Id; 7680 Instantiating : Boolean) return Node_Id 7681 is 7682 Ent : Entity_Id; 7683 New_N : Node_Id; 7684 7685 function Copy_Generic_Descendant (D : Union_Id) return Union_Id; 7686 -- Check the given value of one of the Fields referenced by the current 7687 -- node to determine whether to copy it recursively. The field may hold 7688 -- a Node_Id, a List_Id, or an Elist_Id, or a plain value (Sloc, Uint, 7689 -- Char) in which case it need not be copied. 7690 7691 procedure Copy_Descendants; 7692 -- Common utility for various nodes 7693 7694 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id; 7695 -- Make copy of element list 7696 7697 function Copy_Generic_List 7698 (L : List_Id; 7699 Parent_Id : Node_Id) return List_Id; 7700 -- Apply Copy_Node recursively to the members of a node list 7701 7702 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean; 7703 -- True if an identifier is part of the defining program unit name of 7704 -- a child unit. The entity of such an identifier must be kept (for 7705 -- ASIS use) even though as the name of an enclosing generic it would 7706 -- otherwise not be preserved in the generic tree. 7707 7708 ---------------------- 7709 -- Copy_Descendants -- 7710 ---------------------- 7711 7712 procedure Copy_Descendants is 7713 use Atree.Unchecked_Access; 7714 -- This code section is part of the implementation of an untyped 7715 -- tree traversal, so it needs direct access to node fields. 7716 7717 begin 7718 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 7719 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 7720 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 7721 Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N))); 7722 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 7723 end Copy_Descendants; 7724 7725 ----------------------------- 7726 -- Copy_Generic_Descendant -- 7727 ----------------------------- 7728 7729 function Copy_Generic_Descendant (D : Union_Id) return Union_Id is 7730 begin 7731 if D = Union_Id (Empty) then 7732 return D; 7733 7734 elsif D in Node_Range then 7735 return Union_Id 7736 (Copy_Generic_Node (Node_Id (D), New_N, Instantiating)); 7737 7738 elsif D in List_Range then 7739 return Union_Id (Copy_Generic_List (List_Id (D), New_N)); 7740 7741 elsif D in Elist_Range then 7742 return Union_Id (Copy_Generic_Elist (Elist_Id (D))); 7743 7744 -- Nothing else is copyable (e.g. Uint values), return as is 7745 7746 else 7747 return D; 7748 end if; 7749 end Copy_Generic_Descendant; 7750 7751 ------------------------ 7752 -- Copy_Generic_Elist -- 7753 ------------------------ 7754 7755 function Copy_Generic_Elist (E : Elist_Id) return Elist_Id is 7756 M : Elmt_Id; 7757 L : Elist_Id; 7758 7759 begin 7760 if Present (E) then 7761 L := New_Elmt_List; 7762 M := First_Elmt (E); 7763 while Present (M) loop 7764 Append_Elmt 7765 (Copy_Generic_Node (Node (M), Empty, Instantiating), L); 7766 Next_Elmt (M); 7767 end loop; 7768 7769 return L; 7770 7771 else 7772 return No_Elist; 7773 end if; 7774 end Copy_Generic_Elist; 7775 7776 ----------------------- 7777 -- Copy_Generic_List -- 7778 ----------------------- 7779 7780 function Copy_Generic_List 7781 (L : List_Id; 7782 Parent_Id : Node_Id) return List_Id 7783 is 7784 N : Node_Id; 7785 New_L : List_Id; 7786 7787 begin 7788 if Present (L) then 7789 New_L := New_List; 7790 Set_Parent (New_L, Parent_Id); 7791 7792 N := First (L); 7793 while Present (N) loop 7794 Append (Copy_Generic_Node (N, Empty, Instantiating), New_L); 7795 Next (N); 7796 end loop; 7797 7798 return New_L; 7799 7800 else 7801 return No_List; 7802 end if; 7803 end Copy_Generic_List; 7804 7805 --------------------------- 7806 -- In_Defining_Unit_Name -- 7807 --------------------------- 7808 7809 function In_Defining_Unit_Name (Nam : Node_Id) return Boolean is 7810 begin 7811 return 7812 Present (Parent (Nam)) 7813 and then (Nkind (Parent (Nam)) = N_Defining_Program_Unit_Name 7814 or else 7815 (Nkind (Parent (Nam)) = N_Expanded_Name 7816 and then In_Defining_Unit_Name (Parent (Nam)))); 7817 end In_Defining_Unit_Name; 7818 7819 -- Start of processing for Copy_Generic_Node 7820 7821 begin 7822 if N = Empty then 7823 return N; 7824 end if; 7825 7826 New_N := New_Copy (N); 7827 7828 -- Copy aspects if present 7829 7830 if Has_Aspects (N) then 7831 Set_Has_Aspects (New_N, False); 7832 Set_Aspect_Specifications 7833 (New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id)); 7834 end if; 7835 7836 -- If we are instantiating, we want to adjust the sloc based on the 7837 -- current S_Adjustment. However, if this is the root node of a subunit, 7838 -- we need to defer that adjustment to below (see "elsif Instantiating 7839 -- and Was_Stub"), so it comes after Create_Instantiation_Source has 7840 -- computed the adjustment. 7841 7842 if Instantiating 7843 and then not (Nkind (N) in N_Proper_Body 7844 and then Was_Originally_Stub (N)) 7845 then 7846 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 7847 end if; 7848 7849 if not Is_List_Member (N) then 7850 Set_Parent (New_N, Parent_Id); 7851 end if; 7852 7853 -- Special casing for identifiers and other entity names and operators 7854 7855 if Nkind_In (New_N, N_Character_Literal, 7856 N_Expanded_Name, 7857 N_Identifier, 7858 N_Operator_Symbol) 7859 or else Nkind (New_N) in N_Op 7860 then 7861 if not Instantiating then 7862 7863 -- Link both nodes in order to assign subsequently the entity of 7864 -- the copy to the original node, in case this is a global 7865 -- reference. 7866 7867 Set_Associated_Node (N, New_N); 7868 7869 -- If we are within an instantiation, this is a nested generic 7870 -- that has already been analyzed at the point of definition. 7871 -- We must preserve references that were global to the enclosing 7872 -- parent at that point. Other occurrences, whether global or 7873 -- local to the current generic, must be resolved anew, so we 7874 -- reset the entity in the generic copy. A global reference has a 7875 -- smaller depth than the parent, or else the same depth in case 7876 -- both are distinct compilation units. 7877 7878 -- A child unit is implicitly declared within the enclosing parent 7879 -- but is in fact global to it, and must be preserved. 7880 7881 -- It is also possible for Current_Instantiated_Parent to be 7882 -- defined, and for this not to be a nested generic, namely if 7883 -- the unit is loaded through Rtsfind. In that case, the entity of 7884 -- New_N is only a link to the associated node, and not a defining 7885 -- occurrence. 7886 7887 -- The entities for parent units in the defining_program_unit of a 7888 -- generic child unit are established when the context of the unit 7889 -- is first analyzed, before the generic copy is made. They are 7890 -- preserved in the copy for use in ASIS queries. 7891 7892 Ent := Entity (New_N); 7893 7894 if No (Current_Instantiated_Parent.Gen_Id) then 7895 if No (Ent) 7896 or else Nkind (Ent) /= N_Defining_Identifier 7897 or else not In_Defining_Unit_Name (N) 7898 then 7899 Set_Associated_Node (New_N, Empty); 7900 end if; 7901 7902 elsif No (Ent) 7903 or else 7904 not Nkind_In (Ent, N_Defining_Identifier, 7905 N_Defining_Character_Literal, 7906 N_Defining_Operator_Symbol) 7907 or else No (Scope (Ent)) 7908 or else 7909 (Scope (Ent) = Current_Instantiated_Parent.Gen_Id 7910 and then not Is_Child_Unit (Ent)) 7911 or else 7912 (Scope_Depth (Scope (Ent)) > 7913 Scope_Depth (Current_Instantiated_Parent.Gen_Id) 7914 and then 7915 Get_Source_Unit (Ent) = 7916 Get_Source_Unit (Current_Instantiated_Parent.Gen_Id)) 7917 then 7918 Set_Associated_Node (New_N, Empty); 7919 end if; 7920 7921 -- Case of instantiating identifier or some other name or operator 7922 7923 else 7924 -- If the associated node is still defined, the entity in it 7925 -- is global, and must be copied to the instance. If this copy 7926 -- is being made for a body to inline, it is applied to an 7927 -- instantiated tree, and the entity is already present and 7928 -- must be also preserved. 7929 7930 declare 7931 Assoc : constant Node_Id := Get_Associated_Node (N); 7932 7933 begin 7934 if Present (Assoc) then 7935 if Nkind (Assoc) = Nkind (N) then 7936 Set_Entity (New_N, Entity (Assoc)); 7937 Check_Private_View (N); 7938 7939 -- The node is a reference to a global type and acts as the 7940 -- subtype mark of a qualified expression created in order 7941 -- to aid resolution of accidental overloading in instances. 7942 -- Since N is a reference to a type, the Associated_Node of 7943 -- N denotes an entity rather than another identifier. See 7944 -- Qualify_Universal_Operands for details. 7945 7946 elsif Nkind (N) = N_Identifier 7947 and then Nkind (Parent (N)) = N_Qualified_Expression 7948 and then Subtype_Mark (Parent (N)) = N 7949 and then Is_Qualified_Universal_Literal (Parent (N)) 7950 then 7951 Set_Entity (New_N, Assoc); 7952 7953 -- The name in the call may be a selected component if the 7954 -- call has not been analyzed yet, as may be the case for 7955 -- pre/post conditions in a generic unit. 7956 7957 elsif Nkind (Assoc) = N_Function_Call 7958 and then Is_Entity_Name (Name (Assoc)) 7959 then 7960 Set_Entity (New_N, Entity (Name (Assoc))); 7961 7962 elsif Nkind_In (Assoc, N_Defining_Identifier, 7963 N_Defining_Character_Literal, 7964 N_Defining_Operator_Symbol) 7965 and then Expander_Active 7966 then 7967 -- Inlining case: we are copying a tree that contains 7968 -- global entities, which are preserved in the copy to be 7969 -- used for subsequent inlining. 7970 7971 null; 7972 7973 else 7974 Set_Entity (New_N, Empty); 7975 end if; 7976 end if; 7977 end; 7978 end if; 7979 7980 -- For expanded name, we must copy the Prefix and Selector_Name 7981 7982 if Nkind (N) = N_Expanded_Name then 7983 Set_Prefix 7984 (New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating)); 7985 7986 Set_Selector_Name (New_N, 7987 Copy_Generic_Node (Selector_Name (N), New_N, Instantiating)); 7988 7989 -- For operators, copy the operands 7990 7991 elsif Nkind (N) in N_Op then 7992 if Nkind (N) in N_Binary_Op then 7993 Set_Left_Opnd (New_N, 7994 Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating)); 7995 end if; 7996 7997 Set_Right_Opnd (New_N, 7998 Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating)); 7999 end if; 8000 8001 -- Establish a link between an entity from the generic template and the 8002 -- corresponding entity in the generic copy to be analyzed. 8003 8004 elsif Nkind (N) in N_Entity then 8005 if not Instantiating then 8006 Set_Associated_Entity (N, New_N); 8007 end if; 8008 8009 -- Clear any existing link the copy may inherit from the replicated 8010 -- generic template entity. 8011 8012 Set_Associated_Entity (New_N, Empty); 8013 8014 -- Special casing for stubs 8015 8016 elsif Nkind (N) in N_Body_Stub then 8017 8018 -- In any case, we must copy the specification or defining 8019 -- identifier as appropriate. 8020 8021 if Nkind (N) = N_Subprogram_Body_Stub then 8022 Set_Specification (New_N, 8023 Copy_Generic_Node (Specification (N), New_N, Instantiating)); 8024 8025 else 8026 Set_Defining_Identifier (New_N, 8027 Copy_Generic_Node 8028 (Defining_Identifier (N), New_N, Instantiating)); 8029 end if; 8030 8031 -- If we are not instantiating, then this is where we load and 8032 -- analyze subunits, i.e. at the point where the stub occurs. A 8033 -- more permissive system might defer this analysis to the point 8034 -- of instantiation, but this seems too complicated for now. 8035 8036 if not Instantiating then 8037 declare 8038 Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); 8039 Subunit : Node_Id; 8040 Unum : Unit_Number_Type; 8041 New_Body : Node_Id; 8042 8043 begin 8044 -- Make sure that, if it is a subunit of the main unit that is 8045 -- preprocessed and if -gnateG is specified, the preprocessed 8046 -- file will be written. 8047 8048 Lib.Analysing_Subunit_Of_Main := 8049 Lib.In_Extended_Main_Source_Unit (N); 8050 Unum := 8051 Load_Unit 8052 (Load_Name => Subunit_Name, 8053 Required => False, 8054 Subunit => True, 8055 Error_Node => N); 8056 Lib.Analysing_Subunit_Of_Main := False; 8057 8058 -- If the proper body is not found, a warning message will be 8059 -- emitted when analyzing the stub, or later at the point of 8060 -- instantiation. Here we just leave the stub as is. 8061 8062 if Unum = No_Unit then 8063 Subunits_Missing := True; 8064 goto Subunit_Not_Found; 8065 end if; 8066 8067 Subunit := Cunit (Unum); 8068 8069 if Nkind (Unit (Subunit)) /= N_Subunit then 8070 Error_Msg_N 8071 ("found child unit instead of expected SEPARATE subunit", 8072 Subunit); 8073 Error_Msg_Sloc := Sloc (N); 8074 Error_Msg_N ("\to complete stub #", Subunit); 8075 goto Subunit_Not_Found; 8076 end if; 8077 8078 -- We must create a generic copy of the subunit, in order to 8079 -- perform semantic analysis on it, and we must replace the 8080 -- stub in the original generic unit with the subunit, in order 8081 -- to preserve non-local references within. 8082 8083 -- Only the proper body needs to be copied. Library_Unit and 8084 -- context clause are simply inherited by the generic copy. 8085 -- Note that the copy (which may be recursive if there are 8086 -- nested subunits) must be done first, before attaching it to 8087 -- the enclosing generic. 8088 8089 New_Body := 8090 Copy_Generic_Node 8091 (Proper_Body (Unit (Subunit)), 8092 Empty, Instantiating => False); 8093 8094 -- Now place the original proper body in the original generic 8095 -- unit. This is a body, not a compilation unit. 8096 8097 Rewrite (N, Proper_Body (Unit (Subunit))); 8098 Set_Is_Compilation_Unit (Defining_Entity (N), False); 8099 Set_Was_Originally_Stub (N); 8100 8101 -- Finally replace the body of the subunit with its copy, and 8102 -- make this new subunit into the library unit of the generic 8103 -- copy, which does not have stubs any longer. 8104 8105 Set_Proper_Body (Unit (Subunit), New_Body); 8106 Set_Library_Unit (New_N, Subunit); 8107 Inherit_Context (Unit (Subunit), N); 8108 end; 8109 8110 -- If we are instantiating, this must be an error case, since 8111 -- otherwise we would have replaced the stub node by the proper body 8112 -- that corresponds. So just ignore it in the copy (i.e. we have 8113 -- copied it, and that is good enough). 8114 8115 else 8116 null; 8117 end if; 8118 8119 <<Subunit_Not_Found>> null; 8120 8121 -- If the node is a compilation unit, it is the subunit of a stub, which 8122 -- has been loaded already (see code below). In this case, the library 8123 -- unit field of N points to the parent unit (which is a compilation 8124 -- unit) and need not (and cannot) be copied. 8125 8126 -- When the proper body of the stub is analyzed, the library_unit link 8127 -- is used to establish the proper context (see sem_ch10). 8128 8129 -- The other fields of a compilation unit are copied as usual 8130 8131 elsif Nkind (N) = N_Compilation_Unit then 8132 8133 -- This code can only be executed when not instantiating, because in 8134 -- the copy made for an instantiation, the compilation unit node has 8135 -- disappeared at the point that a stub is replaced by its proper 8136 -- body. 8137 8138 pragma Assert (not Instantiating); 8139 8140 Set_Context_Items (New_N, 8141 Copy_Generic_List (Context_Items (N), New_N)); 8142 8143 Set_Unit (New_N, 8144 Copy_Generic_Node (Unit (N), New_N, Instantiating => False)); 8145 8146 Set_First_Inlined_Subprogram (New_N, 8147 Copy_Generic_Node 8148 (First_Inlined_Subprogram (N), New_N, Instantiating => False)); 8149 8150 Set_Aux_Decls_Node 8151 (New_N, 8152 Copy_Generic_Node 8153 (Aux_Decls_Node (N), New_N, Instantiating => False)); 8154 8155 -- For an assignment node, the assignment is known to be semantically 8156 -- legal if we are instantiating the template. This avoids incorrect 8157 -- diagnostics in generated code. 8158 8159 elsif Nkind (N) = N_Assignment_Statement then 8160 8161 -- Copy name and expression fields in usual manner 8162 8163 Set_Name (New_N, 8164 Copy_Generic_Node (Name (N), New_N, Instantiating)); 8165 8166 Set_Expression (New_N, 8167 Copy_Generic_Node (Expression (N), New_N, Instantiating)); 8168 8169 if Instantiating then 8170 Set_Assignment_OK (Name (New_N), True); 8171 end if; 8172 8173 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 8174 if not Instantiating then 8175 Set_Associated_Node (N, New_N); 8176 8177 else 8178 if Present (Get_Associated_Node (N)) 8179 and then Nkind (Get_Associated_Node (N)) = Nkind (N) 8180 then 8181 -- In the generic the aggregate has some composite type. If at 8182 -- the point of instantiation the type has a private view, 8183 -- install the full view (and that of its ancestors, if any). 8184 8185 declare 8186 T : Entity_Id := (Etype (Get_Associated_Node (New_N))); 8187 Rt : Entity_Id; 8188 8189 begin 8190 if Present (T) and then Is_Private_Type (T) then 8191 Switch_View (T); 8192 end if; 8193 8194 if Present (T) 8195 and then Is_Tagged_Type (T) 8196 and then Is_Derived_Type (T) 8197 then 8198 Rt := Root_Type (T); 8199 8200 loop 8201 T := Etype (T); 8202 8203 if Is_Private_Type (T) then 8204 Switch_View (T); 8205 end if; 8206 8207 exit when T = Rt; 8208 end loop; 8209 end if; 8210 end; 8211 end if; 8212 end if; 8213 8214 -- Do not copy the associated node, which points to the generic copy 8215 -- of the aggregate. 8216 8217 declare 8218 use Atree.Unchecked_Access; 8219 -- This code section is part of the implementation of an untyped 8220 -- tree traversal, so it needs direct access to node fields. 8221 8222 begin 8223 Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N))); 8224 Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N))); 8225 Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N))); 8226 Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N))); 8227 end; 8228 8229 -- Allocators do not have an identifier denoting the access type, so we 8230 -- must locate it through the expression to check whether the views are 8231 -- consistent. 8232 8233 elsif Nkind (N) = N_Allocator 8234 and then Nkind (Expression (N)) = N_Qualified_Expression 8235 and then Is_Entity_Name (Subtype_Mark (Expression (N))) 8236 and then Instantiating 8237 then 8238 declare 8239 T : constant Node_Id := 8240 Get_Associated_Node (Subtype_Mark (Expression (N))); 8241 Acc_T : Entity_Id; 8242 8243 begin 8244 if Present (T) then 8245 8246 -- Retrieve the allocator node in the generic copy 8247 8248 Acc_T := Etype (Parent (Parent (T))); 8249 8250 if Present (Acc_T) and then Is_Private_Type (Acc_T) then 8251 Switch_View (Acc_T); 8252 end if; 8253 end if; 8254 8255 Copy_Descendants; 8256 end; 8257 8258 -- For a proper body, we must catch the case of a proper body that 8259 -- replaces a stub. This represents the point at which a separate 8260 -- compilation unit, and hence template file, may be referenced, so we 8261 -- must make a new source instantiation entry for the template of the 8262 -- subunit, and ensure that all nodes in the subunit are adjusted using 8263 -- this new source instantiation entry. 8264 8265 elsif Nkind (N) in N_Proper_Body then 8266 declare 8267 Save_Adjustment : constant Sloc_Adjustment := S_Adjustment; 8268 begin 8269 if Instantiating and then Was_Originally_Stub (N) then 8270 Create_Instantiation_Source 8271 (Instantiation_Node, 8272 Defining_Entity (N), 8273 S_Adjustment); 8274 8275 Adjust_Instantiation_Sloc (New_N, S_Adjustment); 8276 end if; 8277 8278 -- Now copy the fields of the proper body, using the new 8279 -- adjustment factor if one was needed as per test above. 8280 8281 Copy_Descendants; 8282 8283 -- Restore the original adjustment factor 8284 8285 S_Adjustment := Save_Adjustment; 8286 end; 8287 8288 elsif Nkind (N) = N_Pragma and then Instantiating then 8289 8290 -- Do not copy Comment or Ident pragmas their content is relevant to 8291 -- the generic unit, not to the instantiating unit. 8292 8293 if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then 8294 New_N := Make_Null_Statement (Sloc (N)); 8295 8296 -- Do not copy pragmas generated from aspects because the pragmas do 8297 -- not carry any semantic information, plus they will be regenerated 8298 -- in the instance. 8299 8300 -- However, generating C we need to copy them since postconditions 8301 -- are inlined by the front end, and the front-end inlining machinery 8302 -- relies on this routine to perform inlining. 8303 8304 elsif From_Aspect_Specification (N) 8305 and then not Modify_Tree_For_C 8306 then 8307 New_N := Make_Null_Statement (Sloc (N)); 8308 8309 else 8310 Copy_Descendants; 8311 end if; 8312 8313 elsif Nkind_In (N, N_Integer_Literal, N_Real_Literal) then 8314 8315 -- No descendant fields need traversing 8316 8317 null; 8318 8319 elsif Nkind (N) = N_String_Literal 8320 and then Present (Etype (N)) 8321 and then Instantiating 8322 then 8323 -- If the string is declared in an outer scope, the string_literal 8324 -- subtype created for it may have the wrong scope. Force reanalysis 8325 -- of the constant to generate a new itype in the proper context. 8326 8327 Set_Etype (New_N, Empty); 8328 Set_Analyzed (New_N, False); 8329 8330 -- For the remaining nodes, copy their descendants recursively 8331 8332 else 8333 Copy_Descendants; 8334 8335 if Instantiating and then Nkind (N) = N_Subprogram_Body then 8336 Set_Generic_Parent (Specification (New_N), N); 8337 8338 -- Should preserve Corresponding_Spec??? (12.3(14)) 8339 end if; 8340 end if; 8341 8342 -- Propagate dimensions if present, so that they are reflected in the 8343 -- instance. 8344 8345 if Nkind (N) in N_Has_Etype 8346 and then (Nkind (N) in N_Op or else Is_Entity_Name (N)) 8347 and then Present (Etype (N)) 8348 and then Is_Floating_Point_Type (Etype (N)) 8349 and then Has_Dimension_System (Etype (N)) 8350 then 8351 Copy_Dimensions (N, New_N); 8352 end if; 8353 8354 return New_N; 8355 end Copy_Generic_Node; 8356 8357 ---------------------------- 8358 -- Denotes_Formal_Package -- 8359 ---------------------------- 8360 8361 function Denotes_Formal_Package 8362 (Pack : Entity_Id; 8363 On_Exit : Boolean := False; 8364 Instance : Entity_Id := Empty) return Boolean 8365 is 8366 Par : Entity_Id; 8367 Scop : constant Entity_Id := Scope (Pack); 8368 E : Entity_Id; 8369 8370 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean; 8371 -- The package in question may be an actual for a previous formal 8372 -- package P of the current instance, so examine its actuals as well. 8373 -- This must be recursive over other formal packages. 8374 8375 ---------------------------------- 8376 -- Is_Actual_Of_Previous_Formal -- 8377 ---------------------------------- 8378 8379 function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is 8380 E1 : Entity_Id; 8381 8382 begin 8383 E1 := First_Entity (P); 8384 while Present (E1) and then E1 /= Instance loop 8385 if Ekind (E1) = E_Package 8386 and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration 8387 then 8388 if Renamed_Object (E1) = Pack then 8389 return True; 8390 8391 elsif E1 = P or else Renamed_Object (E1) = P then 8392 return False; 8393 8394 elsif Is_Actual_Of_Previous_Formal (E1) then 8395 return True; 8396 end if; 8397 end if; 8398 8399 Next_Entity (E1); 8400 end loop; 8401 8402 return False; 8403 end Is_Actual_Of_Previous_Formal; 8404 8405 -- Start of processing for Denotes_Formal_Package 8406 8407 begin 8408 if On_Exit then 8409 Par := 8410 Instance_Envs.Table 8411 (Instance_Envs.Last).Instantiated_Parent.Act_Id; 8412 else 8413 Par := Current_Instantiated_Parent.Act_Id; 8414 end if; 8415 8416 if Ekind (Scop) = E_Generic_Package 8417 or else Nkind (Unit_Declaration_Node (Scop)) = 8418 N_Generic_Subprogram_Declaration 8419 then 8420 return True; 8421 8422 elsif Nkind (Original_Node (Unit_Declaration_Node (Pack))) = 8423 N_Formal_Package_Declaration 8424 then 8425 return True; 8426 8427 elsif No (Par) then 8428 return False; 8429 8430 else 8431 -- Check whether this package is associated with a formal package of 8432 -- the enclosing instantiation. Iterate over the list of renamings. 8433 8434 E := First_Entity (Par); 8435 while Present (E) loop 8436 if Ekind (E) /= E_Package 8437 or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration 8438 then 8439 null; 8440 8441 elsif Renamed_Object (E) = Par then 8442 return False; 8443 8444 elsif Renamed_Object (E) = Pack then 8445 return True; 8446 8447 elsif Is_Actual_Of_Previous_Formal (E) then 8448 return True; 8449 8450 end if; 8451 8452 Next_Entity (E); 8453 end loop; 8454 8455 return False; 8456 end if; 8457 end Denotes_Formal_Package; 8458 8459 ----------------- 8460 -- End_Generic -- 8461 ----------------- 8462 8463 procedure End_Generic is 8464 begin 8465 -- ??? More things could be factored out in this routine. Should 8466 -- probably be done at a later stage. 8467 8468 Inside_A_Generic := Generic_Flags.Table (Generic_Flags.Last); 8469 Generic_Flags.Decrement_Last; 8470 8471 Expander_Mode_Restore; 8472 end End_Generic; 8473 8474 ------------- 8475 -- Earlier -- 8476 ------------- 8477 8478 function Earlier (N1, N2 : Node_Id) return Boolean is 8479 procedure Find_Depth (P : in out Node_Id; D : in out Integer); 8480 -- Find distance from given node to enclosing compilation unit 8481 8482 ---------------- 8483 -- Find_Depth -- 8484 ---------------- 8485 8486 procedure Find_Depth (P : in out Node_Id; D : in out Integer) is 8487 begin 8488 while Present (P) 8489 and then Nkind (P) /= N_Compilation_Unit 8490 loop 8491 P := True_Parent (P); 8492 D := D + 1; 8493 end loop; 8494 end Find_Depth; 8495 8496 -- Local declarations 8497 8498 D1 : Integer := 0; 8499 D2 : Integer := 0; 8500 P1 : Node_Id := N1; 8501 P2 : Node_Id := N2; 8502 T1 : Source_Ptr; 8503 T2 : Source_Ptr; 8504 8505 -- Start of processing for Earlier 8506 8507 begin 8508 Find_Depth (P1, D1); 8509 Find_Depth (P2, D2); 8510 8511 if P1 /= P2 then 8512 return False; 8513 else 8514 P1 := N1; 8515 P2 := N2; 8516 end if; 8517 8518 while D1 > D2 loop 8519 P1 := True_Parent (P1); 8520 D1 := D1 - 1; 8521 end loop; 8522 8523 while D2 > D1 loop 8524 P2 := True_Parent (P2); 8525 D2 := D2 - 1; 8526 end loop; 8527 8528 -- At this point P1 and P2 are at the same distance from the root. 8529 -- We examine their parents until we find a common declarative list. 8530 -- If we reach the root, N1 and N2 do not descend from the same 8531 -- declarative list (e.g. one is nested in the declarative part and 8532 -- the other is in a block in the statement part) and the earlier 8533 -- one is already frozen. 8534 8535 while not Is_List_Member (P1) 8536 or else not Is_List_Member (P2) 8537 or else List_Containing (P1) /= List_Containing (P2) 8538 loop 8539 P1 := True_Parent (P1); 8540 P2 := True_Parent (P2); 8541 8542 if Nkind (Parent (P1)) = N_Subunit then 8543 P1 := Corresponding_Stub (Parent (P1)); 8544 end if; 8545 8546 if Nkind (Parent (P2)) = N_Subunit then 8547 P2 := Corresponding_Stub (Parent (P2)); 8548 end if; 8549 8550 if P1 = P2 then 8551 return False; 8552 end if; 8553 end loop; 8554 8555 -- Expanded code usually shares the source location of the original 8556 -- construct it was generated for. This however may not necessarily 8557 -- reflect the true location of the code within the tree. 8558 8559 -- Before comparing the slocs of the two nodes, make sure that we are 8560 -- working with correct source locations. Assume that P1 is to the left 8561 -- of P2. If either one does not come from source, traverse the common 8562 -- list heading towards the other node and locate the first source 8563 -- statement. 8564 8565 -- P1 P2 8566 -- ----+===+===+--------------+===+===+---- 8567 -- expanded code expanded code 8568 8569 if not Comes_From_Source (P1) then 8570 while Present (P1) loop 8571 8572 -- Neither P2 nor a source statement were located during the 8573 -- search. If we reach the end of the list, then P1 does not 8574 -- occur earlier than P2. 8575 8576 -- ----> 8577 -- start --- P2 ----- P1 --- end 8578 8579 if No (Next (P1)) then 8580 return False; 8581 8582 -- We encounter P2 while going to the right of the list. This 8583 -- means that P1 does indeed appear earlier. 8584 8585 -- ----> 8586 -- start --- P1 ===== P2 --- end 8587 -- expanded code in between 8588 8589 elsif P1 = P2 then 8590 return True; 8591 8592 -- No need to look any further since we have located a source 8593 -- statement. 8594 8595 elsif Comes_From_Source (P1) then 8596 exit; 8597 end if; 8598 8599 -- Keep going right 8600 8601 Next (P1); 8602 end loop; 8603 end if; 8604 8605 if not Comes_From_Source (P2) then 8606 while Present (P2) loop 8607 8608 -- Neither P1 nor a source statement were located during the 8609 -- search. If we reach the start of the list, then P1 does not 8610 -- occur earlier than P2. 8611 8612 -- <---- 8613 -- start --- P2 --- P1 --- end 8614 8615 if No (Prev (P2)) then 8616 return False; 8617 8618 -- We encounter P1 while going to the left of the list. This 8619 -- means that P1 does indeed appear earlier. 8620 8621 -- <---- 8622 -- start --- P1 ===== P2 --- end 8623 -- expanded code in between 8624 8625 elsif P2 = P1 then 8626 return True; 8627 8628 -- No need to look any further since we have located a source 8629 -- statement. 8630 8631 elsif Comes_From_Source (P2) then 8632 exit; 8633 end if; 8634 8635 -- Keep going left 8636 8637 Prev (P2); 8638 end loop; 8639 end if; 8640 8641 -- At this point either both nodes came from source or we approximated 8642 -- their source locations through neighboring source statements. 8643 8644 T1 := Top_Level_Location (Sloc (P1)); 8645 T2 := Top_Level_Location (Sloc (P2)); 8646 8647 -- When two nodes come from the same instance, they have identical top 8648 -- level locations. To determine proper relation within the tree, check 8649 -- their locations within the template. 8650 8651 if T1 = T2 then 8652 return Sloc (P1) < Sloc (P2); 8653 8654 -- The two nodes either come from unrelated instances or do not come 8655 -- from instantiated code at all. 8656 8657 else 8658 return T1 < T2; 8659 end if; 8660 end Earlier; 8661 8662 ---------------------- 8663 -- Find_Actual_Type -- 8664 ---------------------- 8665 8666 function Find_Actual_Type 8667 (Typ : Entity_Id; 8668 Gen_Type : Entity_Id) return Entity_Id 8669 is 8670 Gen_Scope : constant Entity_Id := Scope (Gen_Type); 8671 T : Entity_Id; 8672 8673 begin 8674 -- Special processing only applies to child units 8675 8676 if not Is_Child_Unit (Gen_Scope) then 8677 return Get_Instance_Of (Typ); 8678 8679 -- If designated or component type is itself a formal of the child unit, 8680 -- its instance is available. 8681 8682 elsif Scope (Typ) = Gen_Scope then 8683 return Get_Instance_Of (Typ); 8684 8685 -- If the array or access type is not declared in the parent unit, 8686 -- no special processing needed. 8687 8688 elsif not Is_Generic_Type (Typ) 8689 and then Scope (Gen_Scope) /= Scope (Typ) 8690 then 8691 return Get_Instance_Of (Typ); 8692 8693 -- Otherwise, retrieve designated or component type by visibility 8694 8695 else 8696 T := Current_Entity (Typ); 8697 while Present (T) loop 8698 if In_Open_Scopes (Scope (T)) then 8699 return T; 8700 elsif Is_Generic_Actual_Type (T) then 8701 return T; 8702 end if; 8703 8704 T := Homonym (T); 8705 end loop; 8706 8707 return Typ; 8708 end if; 8709 end Find_Actual_Type; 8710 8711 ---------------------------- 8712 -- Freeze_Subprogram_Body -- 8713 ---------------------------- 8714 8715 procedure Freeze_Subprogram_Body 8716 (Inst_Node : Node_Id; 8717 Gen_Body : Node_Id; 8718 Pack_Id : Entity_Id) 8719 is 8720 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 8721 Par : constant Entity_Id := Scope (Gen_Unit); 8722 E_G_Id : Entity_Id; 8723 Enc_G : Entity_Id; 8724 Enc_I : Node_Id; 8725 F_Node : Node_Id; 8726 8727 function Enclosing_Package_Body (N : Node_Id) return Node_Id; 8728 -- Find innermost package body that encloses the given node, and which 8729 -- is not a compilation unit. Freeze nodes for the instance, or for its 8730 -- enclosing body, may be inserted after the enclosing_body of the 8731 -- generic unit. Used to determine proper placement of freeze node for 8732 -- both package and subprogram instances. 8733 8734 function Package_Freeze_Node (B : Node_Id) return Node_Id; 8735 -- Find entity for given package body, and locate or create a freeze 8736 -- node for it. 8737 8738 ---------------------------- 8739 -- Enclosing_Package_Body -- 8740 ---------------------------- 8741 8742 function Enclosing_Package_Body (N : Node_Id) return Node_Id is 8743 P : Node_Id; 8744 8745 begin 8746 P := Parent (N); 8747 while Present (P) 8748 and then Nkind (Parent (P)) /= N_Compilation_Unit 8749 loop 8750 if Nkind (P) = N_Package_Body then 8751 if Nkind (Parent (P)) = N_Subunit then 8752 return Corresponding_Stub (Parent (P)); 8753 else 8754 return P; 8755 end if; 8756 end if; 8757 8758 P := True_Parent (P); 8759 end loop; 8760 8761 return Empty; 8762 end Enclosing_Package_Body; 8763 8764 ------------------------- 8765 -- Package_Freeze_Node -- 8766 ------------------------- 8767 8768 function Package_Freeze_Node (B : Node_Id) return Node_Id is 8769 Id : Entity_Id; 8770 8771 begin 8772 if Nkind (B) = N_Package_Body then 8773 Id := Corresponding_Spec (B); 8774 else pragma Assert (Nkind (B) = N_Package_Body_Stub); 8775 Id := Corresponding_Spec (Proper_Body (Unit (Library_Unit (B)))); 8776 end if; 8777 8778 Ensure_Freeze_Node (Id); 8779 return Freeze_Node (Id); 8780 end Package_Freeze_Node; 8781 8782 -- Start of processing for Freeze_Subprogram_Body 8783 8784 begin 8785 -- If the instance and the generic body appear within the same unit, and 8786 -- the instance precedes the generic, the freeze node for the instance 8787 -- must appear after that of the generic. If the generic is nested 8788 -- within another instance I2, then current instance must be frozen 8789 -- after I2. In both cases, the freeze nodes are those of enclosing 8790 -- packages. Otherwise, the freeze node is placed at the end of the 8791 -- current declarative part. 8792 8793 Enc_G := Enclosing_Package_Body (Gen_Body); 8794 Enc_I := Enclosing_Package_Body (Inst_Node); 8795 Ensure_Freeze_Node (Pack_Id); 8796 F_Node := Freeze_Node (Pack_Id); 8797 8798 if Is_Generic_Instance (Par) 8799 and then Present (Freeze_Node (Par)) 8800 and then In_Same_Declarative_Part 8801 (Parent (Freeze_Node (Par)), Inst_Node) 8802 then 8803 -- The parent was a premature instantiation. Insert freeze node at 8804 -- the end the current declarative part. 8805 8806 if Is_Known_Guaranteed_ABE (Get_Unit_Instantiation_Node (Par)) then 8807 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8808 8809 -- Handle the following case: 8810 -- 8811 -- package Parent_Inst is new ... 8812 -- Parent_Inst [] 8813 -- 8814 -- procedure P ... -- this body freezes Parent_Inst 8815 -- 8816 -- package Inst is new ... 8817 -- 8818 -- In this particular scenario, the freeze node for Inst must be 8819 -- inserted in the same manner as that of Parent_Inst - before the 8820 -- next source body or at the end of the declarative list (body not 8821 -- available). If body P did not exist and Parent_Inst was frozen 8822 -- after Inst, either by a body following Inst or at the end of the 8823 -- declarative region, the freeze node for Inst must be inserted 8824 -- after that of Parent_Inst. This relation is established by 8825 -- comparing the Slocs of Parent_Inst freeze node and Inst. 8826 8827 elsif List_Containing (Get_Unit_Instantiation_Node (Par)) = 8828 List_Containing (Inst_Node) 8829 and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node) 8830 then 8831 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8832 8833 else 8834 Insert_After (Freeze_Node (Par), F_Node); 8835 end if; 8836 8837 -- The body enclosing the instance should be frozen after the body that 8838 -- includes the generic, because the body of the instance may make 8839 -- references to entities therein. If the two are not in the same 8840 -- declarative part, or if the one enclosing the instance is frozen 8841 -- already, freeze the instance at the end of the current declarative 8842 -- part. 8843 8844 elsif Is_Generic_Instance (Par) 8845 and then Present (Freeze_Node (Par)) 8846 and then Present (Enc_I) 8847 then 8848 if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I) 8849 or else 8850 (Nkind (Enc_I) = N_Package_Body 8851 and then In_Same_Declarative_Part 8852 (Parent (Freeze_Node (Par)), Parent (Enc_I))) 8853 then 8854 -- The enclosing package may contain several instances. Rather 8855 -- than computing the earliest point at which to insert its freeze 8856 -- node, we place it at the end of the declarative part of the 8857 -- parent of the generic. 8858 8859 Insert_Freeze_Node_For_Instance 8860 (Freeze_Node (Par), Package_Freeze_Node (Enc_I)); 8861 end if; 8862 8863 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8864 8865 elsif Present (Enc_G) 8866 and then Present (Enc_I) 8867 and then Enc_G /= Enc_I 8868 and then Earlier (Inst_Node, Gen_Body) 8869 then 8870 if Nkind (Enc_G) = N_Package_Body then 8871 E_G_Id := 8872 Corresponding_Spec (Enc_G); 8873 else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub); 8874 E_G_Id := 8875 Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G)))); 8876 end if; 8877 8878 -- Freeze package that encloses instance, and place node after the 8879 -- package that encloses generic. If enclosing package is already 8880 -- frozen we have to assume it is at the proper place. This may be a 8881 -- potential ABE that requires dynamic checking. Do not add a freeze 8882 -- node if the package that encloses the generic is inside the body 8883 -- that encloses the instance, because the freeze node would be in 8884 -- the wrong scope. Additional contortions needed if the bodies are 8885 -- within a subunit. 8886 8887 declare 8888 Enclosing_Body : Node_Id; 8889 8890 begin 8891 if Nkind (Enc_I) = N_Package_Body_Stub then 8892 Enclosing_Body := Proper_Body (Unit (Library_Unit (Enc_I))); 8893 else 8894 Enclosing_Body := Enc_I; 8895 end if; 8896 8897 if Parent (List_Containing (Enc_G)) /= Enclosing_Body then 8898 Insert_Freeze_Node_For_Instance 8899 (Enc_G, Package_Freeze_Node (Enc_I)); 8900 end if; 8901 end; 8902 8903 -- Freeze enclosing subunit before instance 8904 8905 Ensure_Freeze_Node (E_G_Id); 8906 8907 if not Is_List_Member (Freeze_Node (E_G_Id)) then 8908 Insert_After (Enc_G, Freeze_Node (E_G_Id)); 8909 end if; 8910 8911 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8912 8913 else 8914 -- If none of the above, insert freeze node at the end of the current 8915 -- declarative part. 8916 8917 Insert_Freeze_Node_For_Instance (Inst_Node, F_Node); 8918 end if; 8919 end Freeze_Subprogram_Body; 8920 8921 ---------------- 8922 -- Get_Gen_Id -- 8923 ---------------- 8924 8925 function Get_Gen_Id (E : Assoc_Ptr) return Entity_Id is 8926 begin 8927 return Generic_Renamings.Table (E).Gen_Id; 8928 end Get_Gen_Id; 8929 8930 --------------------- 8931 -- Get_Instance_Of -- 8932 --------------------- 8933 8934 function Get_Instance_Of (A : Entity_Id) return Entity_Id is 8935 Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A); 8936 8937 begin 8938 if Res /= Assoc_Null then 8939 return Generic_Renamings.Table (Res).Act_Id; 8940 8941 else 8942 -- On exit, entity is not instantiated: not a generic parameter, or 8943 -- else parameter of an inner generic unit. 8944 8945 return A; 8946 end if; 8947 end Get_Instance_Of; 8948 8949 --------------------------------- 8950 -- Get_Unit_Instantiation_Node -- 8951 --------------------------------- 8952 8953 function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is 8954 Decl : Node_Id := Unit_Declaration_Node (A); 8955 Inst : Node_Id; 8956 8957 begin 8958 -- If the Package_Instantiation attribute has been set on the package 8959 -- entity, then use it directly when it (or its Original_Node) refers 8960 -- to an N_Package_Instantiation node. In principle it should be 8961 -- possible to have this field set in all cases, which should be 8962 -- investigated, and would allow this function to be significantly 8963 -- simplified. ??? 8964 8965 Inst := Package_Instantiation (A); 8966 8967 if Present (Inst) then 8968 if Nkind (Inst) = N_Package_Instantiation then 8969 return Inst; 8970 8971 elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then 8972 return Original_Node (Inst); 8973 end if; 8974 end if; 8975 8976 -- If the instantiation is a compilation unit that does not need body 8977 -- then the instantiation node has been rewritten as a package 8978 -- declaration for the instance, and we return the original node. 8979 8980 -- If it is a compilation unit and the instance node has not been 8981 -- rewritten, then it is still the unit of the compilation. Finally, if 8982 -- a body is present, this is a parent of the main unit whose body has 8983 -- been compiled for inlining purposes, and the instantiation node has 8984 -- been rewritten with the instance body. 8985 8986 -- Otherwise the instantiation node appears after the declaration. If 8987 -- the entity is a formal package, the declaration may have been 8988 -- rewritten as a generic declaration (in the case of a formal with box) 8989 -- or left as a formal package declaration if it has actuals, and is 8990 -- found with a forward search. 8991 8992 if Nkind (Parent (Decl)) = N_Compilation_Unit then 8993 if Nkind (Decl) = N_Package_Declaration 8994 and then Present (Corresponding_Body (Decl)) 8995 then 8996 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 8997 end if; 8998 8999 if Nkind (Original_Node (Decl)) in N_Generic_Instantiation then 9000 return Original_Node (Decl); 9001 else 9002 return Unit (Parent (Decl)); 9003 end if; 9004 9005 elsif Nkind (Decl) = N_Package_Declaration 9006 and then Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration 9007 then 9008 return Original_Node (Decl); 9009 9010 else 9011 Inst := Next (Decl); 9012 while not Nkind_In (Inst, N_Formal_Package_Declaration, 9013 N_Function_Instantiation, 9014 N_Package_Instantiation, 9015 N_Procedure_Instantiation) 9016 loop 9017 Next (Inst); 9018 end loop; 9019 9020 return Inst; 9021 end if; 9022 end Get_Unit_Instantiation_Node; 9023 9024 ------------------------ 9025 -- Has_Been_Exchanged -- 9026 ------------------------ 9027 9028 function Has_Been_Exchanged (E : Entity_Id) return Boolean is 9029 Next : Elmt_Id; 9030 9031 begin 9032 Next := First_Elmt (Exchanged_Views); 9033 while Present (Next) loop 9034 if Full_View (Node (Next)) = E then 9035 return True; 9036 end if; 9037 9038 Next_Elmt (Next); 9039 end loop; 9040 9041 return False; 9042 end Has_Been_Exchanged; 9043 9044 ---------- 9045 -- Hash -- 9046 ---------- 9047 9048 function Hash (F : Entity_Id) return HTable_Range is 9049 begin 9050 return HTable_Range (F mod HTable_Size); 9051 end Hash; 9052 9053 ------------------------ 9054 -- Hide_Current_Scope -- 9055 ------------------------ 9056 9057 procedure Hide_Current_Scope is 9058 C : constant Entity_Id := Current_Scope; 9059 E : Entity_Id; 9060 9061 begin 9062 Set_Is_Hidden_Open_Scope (C); 9063 9064 E := First_Entity (C); 9065 while Present (E) loop 9066 if Is_Immediately_Visible (E) then 9067 Set_Is_Immediately_Visible (E, False); 9068 Append_Elmt (E, Hidden_Entities); 9069 end if; 9070 9071 Next_Entity (E); 9072 end loop; 9073 9074 -- Make the scope name invisible as well. This is necessary, but might 9075 -- conflict with calls to Rtsfind later on, in case the scope is a 9076 -- predefined one. There is no clean solution to this problem, so for 9077 -- now we depend on the user not redefining Standard itself in one of 9078 -- the parent units. 9079 9080 if Is_Immediately_Visible (C) and then C /= Standard_Standard then 9081 Set_Is_Immediately_Visible (C, False); 9082 Append_Elmt (C, Hidden_Entities); 9083 end if; 9084 9085 end Hide_Current_Scope; 9086 9087 -------------- 9088 -- Init_Env -- 9089 -------------- 9090 9091 procedure Init_Env is 9092 Saved : Instance_Env; 9093 9094 begin 9095 Saved.Instantiated_Parent := Current_Instantiated_Parent; 9096 Saved.Exchanged_Views := Exchanged_Views; 9097 Saved.Hidden_Entities := Hidden_Entities; 9098 Saved.Current_Sem_Unit := Current_Sem_Unit; 9099 Saved.Parent_Unit_Visible := Parent_Unit_Visible; 9100 Saved.Instance_Parent_Unit := Instance_Parent_Unit; 9101 9102 -- Save configuration switches. These may be reset if the unit is a 9103 -- predefined unit, and the current mode is not Ada 2005. 9104 9105 Saved.Switches := Save_Config_Switches; 9106 9107 Instance_Envs.Append (Saved); 9108 9109 Exchanged_Views := New_Elmt_List; 9110 Hidden_Entities := New_Elmt_List; 9111 9112 -- Make dummy entry for Instantiated parent. If generic unit is legal, 9113 -- this is set properly in Set_Instance_Env. 9114 9115 Current_Instantiated_Parent := 9116 (Current_Scope, Current_Scope, Assoc_Null); 9117 end Init_Env; 9118 9119 --------------------- 9120 -- In_Main_Context -- 9121 --------------------- 9122 9123 function In_Main_Context (E : Entity_Id) return Boolean is 9124 Context : List_Id; 9125 Clause : Node_Id; 9126 Nam : Node_Id; 9127 9128 begin 9129 if not Is_Compilation_Unit (E) 9130 or else Ekind (E) /= E_Package 9131 or else In_Private_Part (E) 9132 then 9133 return False; 9134 end if; 9135 9136 Context := Context_Items (Cunit (Main_Unit)); 9137 9138 Clause := First (Context); 9139 while Present (Clause) loop 9140 if Nkind (Clause) = N_With_Clause then 9141 Nam := Name (Clause); 9142 9143 -- If the current scope is part of the context of the main unit, 9144 -- analysis of the corresponding with_clause is not complete, and 9145 -- the entity is not set. We use the Chars field directly, which 9146 -- might produce false positives in rare cases, but guarantees 9147 -- that we produce all the instance bodies we will need. 9148 9149 if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E)) 9150 or else (Nkind (Nam) = N_Selected_Component 9151 and then Chars (Selector_Name (Nam)) = Chars (E)) 9152 then 9153 return True; 9154 end if; 9155 end if; 9156 9157 Next (Clause); 9158 end loop; 9159 9160 return False; 9161 end In_Main_Context; 9162 9163 --------------------- 9164 -- Inherit_Context -- 9165 --------------------- 9166 9167 procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id) is 9168 Current_Context : List_Id; 9169 Current_Unit : Node_Id; 9170 Item : Node_Id; 9171 New_I : Node_Id; 9172 9173 Clause : Node_Id; 9174 OK : Boolean; 9175 Lib_Unit : Node_Id; 9176 9177 begin 9178 if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then 9179 9180 -- The inherited context is attached to the enclosing compilation 9181 -- unit. This is either the main unit, or the declaration for the 9182 -- main unit (in case the instantiation appears within the package 9183 -- declaration and the main unit is its body). 9184 9185 Current_Unit := Parent (Inst); 9186 while Present (Current_Unit) 9187 and then Nkind (Current_Unit) /= N_Compilation_Unit 9188 loop 9189 Current_Unit := Parent (Current_Unit); 9190 end loop; 9191 9192 Current_Context := Context_Items (Current_Unit); 9193 9194 Item := First (Context_Items (Parent (Gen_Decl))); 9195 while Present (Item) loop 9196 if Nkind (Item) = N_With_Clause then 9197 Lib_Unit := Library_Unit (Item); 9198 9199 -- Take care to prevent direct cyclic with's 9200 9201 if Lib_Unit /= Current_Unit then 9202 9203 -- Do not add a unit if it is already in the context 9204 9205 Clause := First (Current_Context); 9206 OK := True; 9207 while Present (Clause) loop 9208 if Nkind (Clause) = N_With_Clause 9209 and then Library_Unit (Clause) = Lib_Unit 9210 then 9211 OK := False; 9212 exit; 9213 end if; 9214 9215 Next (Clause); 9216 end loop; 9217 9218 if OK then 9219 New_I := New_Copy (Item); 9220 Set_Implicit_With (New_I); 9221 9222 Append (New_I, Current_Context); 9223 end if; 9224 end if; 9225 end if; 9226 9227 Next (Item); 9228 end loop; 9229 end if; 9230 end Inherit_Context; 9231 9232 ---------------- 9233 -- Initialize -- 9234 ---------------- 9235 9236 procedure Initialize is 9237 begin 9238 Generic_Renamings.Init; 9239 Instance_Envs.Init; 9240 Generic_Flags.Init; 9241 Generic_Renamings_HTable.Reset; 9242 Circularity_Detected := False; 9243 Exchanged_Views := No_Elist; 9244 Hidden_Entities := No_Elist; 9245 end Initialize; 9246 9247 ------------------------------------- 9248 -- Insert_Freeze_Node_For_Instance -- 9249 ------------------------------------- 9250 9251 procedure Insert_Freeze_Node_For_Instance 9252 (N : Node_Id; 9253 F_Node : Node_Id) 9254 is 9255 Decl : Node_Id; 9256 Decls : List_Id; 9257 Inst : Entity_Id; 9258 Par_N : Node_Id; 9259 9260 function Enclosing_Body (N : Node_Id) return Node_Id; 9261 -- Find enclosing package or subprogram body, if any. Freeze node may 9262 -- be placed at end of current declarative list if previous instance 9263 -- and current one have different enclosing bodies. 9264 9265 function Previous_Instance (Gen : Entity_Id) return Entity_Id; 9266 -- Find the local instance, if any, that declares the generic that is 9267 -- being instantiated. If present, the freeze node for this instance 9268 -- must follow the freeze node for the previous instance. 9269 9270 -------------------- 9271 -- Enclosing_Body -- 9272 -------------------- 9273 9274 function Enclosing_Body (N : Node_Id) return Node_Id is 9275 P : Node_Id; 9276 9277 begin 9278 P := Parent (N); 9279 while Present (P) 9280 and then Nkind (Parent (P)) /= N_Compilation_Unit 9281 loop 9282 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 9283 if Nkind (Parent (P)) = N_Subunit then 9284 return Corresponding_Stub (Parent (P)); 9285 else 9286 return P; 9287 end if; 9288 end if; 9289 9290 P := True_Parent (P); 9291 end loop; 9292 9293 return Empty; 9294 end Enclosing_Body; 9295 9296 ----------------------- 9297 -- Previous_Instance -- 9298 ----------------------- 9299 9300 function Previous_Instance (Gen : Entity_Id) return Entity_Id is 9301 S : Entity_Id; 9302 9303 begin 9304 S := Scope (Gen); 9305 while Present (S) and then S /= Standard_Standard loop 9306 if Is_Generic_Instance (S) 9307 and then In_Same_Source_Unit (S, N) 9308 then 9309 return S; 9310 end if; 9311 9312 S := Scope (S); 9313 end loop; 9314 9315 return Empty; 9316 end Previous_Instance; 9317 9318 -- Start of processing for Insert_Freeze_Node_For_Instance 9319 9320 begin 9321 if not Is_List_Member (F_Node) then 9322 Decl := N; 9323 Decls := List_Containing (N); 9324 Inst := Entity (F_Node); 9325 Par_N := Parent (Decls); 9326 9327 -- When processing a subprogram instantiation, utilize the actual 9328 -- subprogram instantiation rather than its package wrapper as it 9329 -- carries all the context information. 9330 9331 if Is_Wrapper_Package (Inst) then 9332 Inst := Related_Instance (Inst); 9333 end if; 9334 9335 -- If this is a package instance, check whether the generic is 9336 -- declared in a previous instance and the current instance is 9337 -- not within the previous one. 9338 9339 if Present (Generic_Parent (Parent (Inst))) 9340 and then Is_In_Main_Unit (N) 9341 then 9342 declare 9343 Enclosing_N : constant Node_Id := Enclosing_Body (N); 9344 Par_I : constant Entity_Id := 9345 Previous_Instance 9346 (Generic_Parent (Parent (Inst))); 9347 Scop : Entity_Id; 9348 9349 begin 9350 if Present (Par_I) 9351 and then Earlier (N, Freeze_Node (Par_I)) 9352 then 9353 Scop := Scope (Inst); 9354 9355 -- If the current instance is within the one that contains 9356 -- the generic, the freeze node for the current one must 9357 -- appear in the current declarative part. Ditto, if the 9358 -- current instance is within another package instance or 9359 -- within a body that does not enclose the current instance. 9360 -- In these three cases the freeze node of the previous 9361 -- instance is not relevant. 9362 9363 while Present (Scop) and then Scop /= Standard_Standard loop 9364 exit when Scop = Par_I 9365 or else 9366 (Is_Generic_Instance (Scop) 9367 and then Scope_Depth (Scop) > Scope_Depth (Par_I)); 9368 Scop := Scope (Scop); 9369 end loop; 9370 9371 -- Previous instance encloses current instance 9372 9373 if Scop = Par_I then 9374 null; 9375 9376 -- If the next node is a source body we must freeze in 9377 -- the current scope as well. 9378 9379 elsif Present (Next (N)) 9380 and then Nkind_In (Next (N), N_Subprogram_Body, 9381 N_Package_Body) 9382 and then Comes_From_Source (Next (N)) 9383 then 9384 null; 9385 9386 -- Current instance is within an unrelated instance 9387 9388 elsif Is_Generic_Instance (Scop) then 9389 null; 9390 9391 -- Current instance is within an unrelated body 9392 9393 elsif Present (Enclosing_N) 9394 and then Enclosing_N /= Enclosing_Body (Par_I) 9395 then 9396 null; 9397 9398 else 9399 Insert_After (Freeze_Node (Par_I), F_Node); 9400 return; 9401 end if; 9402 end if; 9403 end; 9404 end if; 9405 9406 -- When the instantiation occurs in a package declaration, append the 9407 -- freeze node to the private declarations (if any). 9408 9409 if Nkind (Par_N) = N_Package_Specification 9410 and then Decls = Visible_Declarations (Par_N) 9411 and then Present (Private_Declarations (Par_N)) 9412 and then not Is_Empty_List (Private_Declarations (Par_N)) 9413 then 9414 Decls := Private_Declarations (Par_N); 9415 Decl := First (Decls); 9416 end if; 9417 9418 -- Determine the proper freeze point of a package instantiation. We 9419 -- adhere to the general rule of a package or subprogram body causing 9420 -- freezing of anything before it in the same declarative region. In 9421 -- this case, the proper freeze point of a package instantiation is 9422 -- before the first source body which follows, or before a stub. This 9423 -- ensures that entities coming from the instance are already frozen 9424 -- and usable in source bodies. 9425 9426 if Nkind (Par_N) /= N_Package_Declaration 9427 and then Ekind (Inst) = E_Package 9428 and then Is_Generic_Instance (Inst) 9429 and then 9430 not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst) 9431 then 9432 while Present (Decl) loop 9433 if (Nkind (Decl) in N_Unit_Body 9434 or else 9435 Nkind (Decl) in N_Body_Stub) 9436 and then Comes_From_Source (Decl) 9437 then 9438 Insert_Before (Decl, F_Node); 9439 return; 9440 end if; 9441 9442 Next (Decl); 9443 end loop; 9444 end if; 9445 9446 -- In a package declaration, or if no previous body, insert at end 9447 -- of list. 9448 9449 Set_Sloc (F_Node, Sloc (Last (Decls))); 9450 Insert_After (Last (Decls), F_Node); 9451 end if; 9452 end Insert_Freeze_Node_For_Instance; 9453 9454 ------------------ 9455 -- Install_Body -- 9456 ------------------ 9457 9458 procedure Install_Body 9459 (Act_Body : Node_Id; 9460 N : Node_Id; 9461 Gen_Body : Node_Id; 9462 Gen_Decl : Node_Id) 9463 is 9464 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean; 9465 -- Check if the generic definition and the instantiation come from 9466 -- a common scope, in which case the instance must be frozen after 9467 -- the generic body. 9468 9469 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr; 9470 -- If the instance is nested inside a generic unit, the Sloc of the 9471 -- instance indicates the place of the original definition, not the 9472 -- point of the current enclosing instance. Pending a better usage of 9473 -- Slocs to indicate instantiation places, we determine the place of 9474 -- origin of a node by finding the maximum sloc of any ancestor node. 9475 -- Why is this not equivalent to Top_Level_Location ??? 9476 9477 ------------------- 9478 -- In_Same_Scope -- 9479 ------------------- 9480 9481 function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is 9482 Act_Scop : Entity_Id := Scope (Act_Id); 9483 Gen_Scop : Entity_Id := Scope (Gen_Id); 9484 9485 begin 9486 while Act_Scop /= Standard_Standard 9487 and then Gen_Scop /= Standard_Standard 9488 loop 9489 if Act_Scop = Gen_Scop then 9490 return True; 9491 end if; 9492 9493 Act_Scop := Scope (Act_Scop); 9494 Gen_Scop := Scope (Gen_Scop); 9495 end loop; 9496 9497 return False; 9498 end In_Same_Scope; 9499 9500 --------------- 9501 -- True_Sloc -- 9502 --------------- 9503 9504 function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is 9505 N1 : Node_Id; 9506 Res : Source_Ptr; 9507 9508 begin 9509 Res := Sloc (N); 9510 N1 := N; 9511 while Present (N1) and then N1 /= Act_Unit loop 9512 if Sloc (N1) > Res then 9513 Res := Sloc (N1); 9514 end if; 9515 9516 N1 := Parent (N1); 9517 end loop; 9518 9519 return Res; 9520 end True_Sloc; 9521 9522 Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); 9523 Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); 9524 Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); 9525 Par : constant Entity_Id := Scope (Gen_Id); 9526 Gen_Unit : constant Node_Id := 9527 Unit (Cunit (Get_Source_Unit (Gen_Decl))); 9528 9529 Body_Unit : Node_Id; 9530 F_Node : Node_Id; 9531 Must_Delay : Boolean; 9532 Orig_Body : Node_Id := Gen_Body; 9533 9534 -- Start of processing for Install_Body 9535 9536 begin 9537 -- Handle first the case of an instance with incomplete actual types. 9538 -- The instance body cannot be placed after the declaration because 9539 -- full views have not been seen yet. Any use of the non-limited views 9540 -- in the instance body requires the presence of a regular with_clause 9541 -- in the enclosing unit, and will fail if this with_clause is missing. 9542 -- We place the instance body at the beginning of the enclosing body, 9543 -- which is the unit being compiled. The freeze node for the instance 9544 -- is then placed after the instance body. 9545 9546 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) 9547 and then Expander_Active 9548 and then Ekind (Scope (Act_Id)) = E_Package 9549 then 9550 declare 9551 Scop : constant Entity_Id := Scope (Act_Id); 9552 Body_Id : constant Node_Id := 9553 Corresponding_Body (Unit_Declaration_Node (Scop)); 9554 9555 begin 9556 Ensure_Freeze_Node (Act_Id); 9557 F_Node := Freeze_Node (Act_Id); 9558 if Present (Body_Id) then 9559 Set_Is_Frozen (Act_Id, False); 9560 Prepend (Act_Body, Declarations (Parent (Body_Id))); 9561 if Is_List_Member (F_Node) then 9562 Remove (F_Node); 9563 end if; 9564 9565 Insert_After (Act_Body, F_Node); 9566 end if; 9567 end; 9568 return; 9569 end if; 9570 9571 -- If the body is a subunit, the freeze point is the corresponding stub 9572 -- in the current compilation, not the subunit itself. 9573 9574 if Nkind (Parent (Gen_Body)) = N_Subunit then 9575 Orig_Body := Corresponding_Stub (Parent (Gen_Body)); 9576 else 9577 Orig_Body := Gen_Body; 9578 end if; 9579 9580 Body_Unit := Unit (Cunit (Get_Source_Unit (Orig_Body))); 9581 9582 -- If the instantiation and the generic definition appear in the same 9583 -- package declaration, this is an early instantiation. If they appear 9584 -- in the same declarative part, it is an early instantiation only if 9585 -- the generic body appears textually later, and the generic body is 9586 -- also in the main unit. 9587 9588 -- If instance is nested within a subprogram, and the generic body 9589 -- is not, the instance is delayed because the enclosing body is. If 9590 -- instance and body are within the same scope, or the same subprogram 9591 -- body, indicate explicitly that the instance is delayed. 9592 9593 Must_Delay := 9594 (Gen_Unit = Act_Unit 9595 and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration, 9596 N_Package_Declaration) 9597 or else (Gen_Unit = Body_Unit 9598 and then True_Sloc (N, Act_Unit) < 9599 Sloc (Orig_Body))) 9600 and then Is_In_Main_Unit (Original_Node (Gen_Unit)) 9601 and then In_Same_Scope (Gen_Id, Act_Id)); 9602 9603 -- If this is an early instantiation, the freeze node is placed after 9604 -- the generic body. Otherwise, if the generic appears in an instance, 9605 -- we cannot freeze the current instance until the outer one is frozen. 9606 -- This is only relevant if the current instance is nested within some 9607 -- inner scope not itself within the outer instance. If this scope is 9608 -- a package body in the same declarative part as the outer instance, 9609 -- then that body needs to be frozen after the outer instance. Finally, 9610 -- if no delay is needed, we place the freeze node at the end of the 9611 -- current declarative part. 9612 9613 if Expander_Active 9614 and then (No (Freeze_Node (Act_Id)) 9615 or else not Is_List_Member (Freeze_Node (Act_Id))) 9616 then 9617 Ensure_Freeze_Node (Act_Id); 9618 F_Node := Freeze_Node (Act_Id); 9619 9620 if Must_Delay then 9621 Insert_After (Orig_Body, F_Node); 9622 9623 elsif Is_Generic_Instance (Par) 9624 and then Present (Freeze_Node (Par)) 9625 and then Scope (Act_Id) /= Par 9626 then 9627 -- Freeze instance of inner generic after instance of enclosing 9628 -- generic. 9629 9630 if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), N) then 9631 9632 -- Handle the following case: 9633 9634 -- package Parent_Inst is new ... 9635 -- Parent_Inst [] 9636 9637 -- procedure P ... -- this body freezes Parent_Inst 9638 9639 -- package Inst is new ... 9640 9641 -- In this particular scenario, the freeze node for Inst must 9642 -- be inserted in the same manner as that of Parent_Inst, 9643 -- before the next source body or at the end of the declarative 9644 -- list (body not available). If body P did not exist and 9645 -- Parent_Inst was frozen after Inst, either by a body 9646 -- following Inst or at the end of the declarative region, 9647 -- the freeze node for Inst must be inserted after that of 9648 -- Parent_Inst. This relation is established by comparing 9649 -- the Slocs of Parent_Inst freeze node and Inst. 9650 -- We examine the parents of the enclosing lists to handle 9651 -- the case where the parent instance is in the visible part 9652 -- of a package declaration, and the inner instance is in 9653 -- the corresponding private part. 9654 9655 if Parent (List_Containing (Get_Unit_Instantiation_Node (Par))) 9656 = Parent (List_Containing (N)) 9657 and then Sloc (Freeze_Node (Par)) < Sloc (N) 9658 then 9659 Insert_Freeze_Node_For_Instance (N, F_Node); 9660 else 9661 Insert_After (Freeze_Node (Par), F_Node); 9662 end if; 9663 9664 -- Freeze package enclosing instance of inner generic after 9665 -- instance of enclosing generic. 9666 9667 elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body) 9668 and then In_Same_Declarative_Part 9669 (Parent (Freeze_Node (Par)), Parent (N)) 9670 then 9671 declare 9672 Enclosing : Entity_Id; 9673 9674 begin 9675 Enclosing := Corresponding_Spec (Parent (N)); 9676 9677 if No (Enclosing) then 9678 Enclosing := Defining_Entity (Parent (N)); 9679 end if; 9680 9681 Insert_Freeze_Node_For_Instance (N, F_Node); 9682 Ensure_Freeze_Node (Enclosing); 9683 9684 if not Is_List_Member (Freeze_Node (Enclosing)) then 9685 9686 -- The enclosing context is a subunit, insert the freeze 9687 -- node after the stub. 9688 9689 if Nkind (Parent (Parent (N))) = N_Subunit then 9690 Insert_Freeze_Node_For_Instance 9691 (Corresponding_Stub (Parent (Parent (N))), 9692 Freeze_Node (Enclosing)); 9693 9694 -- The enclosing context is a package with a stub body 9695 -- which has already been replaced by the real body. 9696 -- Insert the freeze node after the actual body. 9697 9698 elsif Ekind (Enclosing) = E_Package 9699 and then Present (Body_Entity (Enclosing)) 9700 and then Was_Originally_Stub 9701 (Parent (Body_Entity (Enclosing))) 9702 then 9703 Insert_Freeze_Node_For_Instance 9704 (Parent (Body_Entity (Enclosing)), 9705 Freeze_Node (Enclosing)); 9706 9707 -- The parent instance has been frozen before the body of 9708 -- the enclosing package, insert the freeze node after 9709 -- the body. 9710 9711 elsif List_Containing (Freeze_Node (Par)) = 9712 List_Containing (Parent (N)) 9713 and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N)) 9714 then 9715 Insert_Freeze_Node_For_Instance 9716 (Parent (N), Freeze_Node (Enclosing)); 9717 9718 else 9719 Insert_After 9720 (Freeze_Node (Par), Freeze_Node (Enclosing)); 9721 end if; 9722 end if; 9723 end; 9724 9725 else 9726 Insert_Freeze_Node_For_Instance (N, F_Node); 9727 end if; 9728 9729 else 9730 Insert_Freeze_Node_For_Instance (N, F_Node); 9731 end if; 9732 end if; 9733 9734 Set_Is_Frozen (Act_Id); 9735 Insert_Before (N, Act_Body); 9736 Mark_Rewrite_Insertion (Act_Body); 9737 end Install_Body; 9738 9739 ----------------------------- 9740 -- Install_Formal_Packages -- 9741 ----------------------------- 9742 9743 procedure Install_Formal_Packages (Par : Entity_Id) is 9744 E : Entity_Id; 9745 Gen : Entity_Id; 9746 Gen_E : Entity_Id := Empty; 9747 9748 begin 9749 E := First_Entity (Par); 9750 9751 -- If we are installing an instance parent, locate the formal packages 9752 -- of its generic parent. 9753 9754 if Is_Generic_Instance (Par) then 9755 Gen := Generic_Parent (Package_Specification (Par)); 9756 Gen_E := First_Entity (Gen); 9757 end if; 9758 9759 while Present (E) loop 9760 if Ekind (E) = E_Package 9761 and then Nkind (Parent (E)) = N_Package_Renaming_Declaration 9762 then 9763 -- If this is the renaming for the parent instance, done 9764 9765 if Renamed_Object (E) = Par then 9766 exit; 9767 9768 -- The visibility of a formal of an enclosing generic is already 9769 -- correct. 9770 9771 elsif Denotes_Formal_Package (E) then 9772 null; 9773 9774 elsif Present (Associated_Formal_Package (E)) then 9775 Check_Generic_Actuals (Renamed_Object (E), True); 9776 Set_Is_Hidden (E, False); 9777 9778 -- Find formal package in generic unit that corresponds to 9779 -- (instance of) formal package in instance. 9780 9781 while Present (Gen_E) and then Chars (Gen_E) /= Chars (E) loop 9782 Next_Entity (Gen_E); 9783 end loop; 9784 9785 if Present (Gen_E) then 9786 Map_Formal_Package_Entities (Gen_E, E); 9787 end if; 9788 end if; 9789 end if; 9790 9791 Next_Entity (E); 9792 9793 if Present (Gen_E) then 9794 Next_Entity (Gen_E); 9795 end if; 9796 end loop; 9797 end Install_Formal_Packages; 9798 9799 -------------------- 9800 -- Install_Parent -- 9801 -------------------- 9802 9803 procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is 9804 Ancestors : constant Elist_Id := New_Elmt_List; 9805 S : constant Entity_Id := Current_Scope; 9806 Inst_Par : Entity_Id; 9807 First_Par : Entity_Id; 9808 Inst_Node : Node_Id; 9809 Gen_Par : Entity_Id; 9810 First_Gen : Entity_Id; 9811 Elmt : Elmt_Id; 9812 9813 procedure Install_Noninstance_Specs (Par : Entity_Id); 9814 -- Install the scopes of noninstance parent units ending with Par 9815 9816 procedure Install_Spec (Par : Entity_Id); 9817 -- The child unit is within the declarative part of the parent, so the 9818 -- declarations within the parent are immediately visible. 9819 9820 ------------------------------- 9821 -- Install_Noninstance_Specs -- 9822 ------------------------------- 9823 9824 procedure Install_Noninstance_Specs (Par : Entity_Id) is 9825 begin 9826 if Present (Par) 9827 and then Par /= Standard_Standard 9828 and then not In_Open_Scopes (Par) 9829 then 9830 Install_Noninstance_Specs (Scope (Par)); 9831 Install_Spec (Par); 9832 end if; 9833 end Install_Noninstance_Specs; 9834 9835 ------------------ 9836 -- Install_Spec -- 9837 ------------------ 9838 9839 procedure Install_Spec (Par : Entity_Id) is 9840 Spec : constant Node_Id := Package_Specification (Par); 9841 9842 begin 9843 -- If this parent of the child instance is a top-level unit, 9844 -- then record the unit and its visibility for later resetting in 9845 -- Remove_Parent. We exclude units that are generic instances, as we 9846 -- only want to record this information for the ultimate top-level 9847 -- noninstance parent (is that always correct???). 9848 9849 if Scope (Par) = Standard_Standard 9850 and then not Is_Generic_Instance (Par) 9851 then 9852 Parent_Unit_Visible := Is_Immediately_Visible (Par); 9853 Instance_Parent_Unit := Par; 9854 end if; 9855 9856 -- Open the parent scope and make it and its declarations visible. 9857 -- If this point is not within a body, then only the visible 9858 -- declarations should be made visible, and installation of the 9859 -- private declarations is deferred until the appropriate point 9860 -- within analysis of the spec being instantiated (see the handling 9861 -- of parent visibility in Analyze_Package_Specification). This is 9862 -- relaxed in the case where the parent unit is Ada.Tags, to avoid 9863 -- private view problems that occur when compiling instantiations of 9864 -- a generic child of that package (Generic_Dispatching_Constructor). 9865 -- If the instance freezes a tagged type, inlinings of operations 9866 -- from Ada.Tags may need the full view of type Tag. If inlining took 9867 -- proper account of establishing visibility of inlined subprograms' 9868 -- parents then it should be possible to remove this 9869 -- special check. ??? 9870 9871 Push_Scope (Par); 9872 Set_Is_Immediately_Visible (Par); 9873 Install_Visible_Declarations (Par); 9874 Set_Use (Visible_Declarations (Spec)); 9875 9876 if In_Body or else Is_RTU (Par, Ada_Tags) then 9877 Install_Private_Declarations (Par); 9878 Set_Use (Private_Declarations (Spec)); 9879 end if; 9880 end Install_Spec; 9881 9882 -- Start of processing for Install_Parent 9883 9884 begin 9885 -- We need to install the parent instance to compile the instantiation 9886 -- of the child, but the child instance must appear in the current 9887 -- scope. Given that we cannot place the parent above the current scope 9888 -- in the scope stack, we duplicate the current scope and unstack both 9889 -- after the instantiation is complete. 9890 9891 -- If the parent is itself the instantiation of a child unit, we must 9892 -- also stack the instantiation of its parent, and so on. Each such 9893 -- ancestor is the prefix of the name in a prior instantiation. 9894 9895 -- If this is a nested instance, the parent unit itself resolves to 9896 -- a renaming of the parent instance, whose declaration we need. 9897 9898 -- Finally, the parent may be a generic (not an instance) when the 9899 -- child unit appears as a formal package. 9900 9901 Inst_Par := P; 9902 9903 if Present (Renamed_Entity (Inst_Par)) then 9904 Inst_Par := Renamed_Entity (Inst_Par); 9905 end if; 9906 9907 First_Par := Inst_Par; 9908 9909 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9910 9911 First_Gen := Gen_Par; 9912 9913 while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop 9914 9915 -- Load grandparent instance as well 9916 9917 Inst_Node := Get_Unit_Instantiation_Node (Inst_Par); 9918 9919 if Nkind (Name (Inst_Node)) = N_Expanded_Name then 9920 Inst_Par := Entity (Prefix (Name (Inst_Node))); 9921 9922 if Present (Renamed_Entity (Inst_Par)) then 9923 Inst_Par := Renamed_Entity (Inst_Par); 9924 end if; 9925 9926 Gen_Par := Generic_Parent (Package_Specification (Inst_Par)); 9927 9928 if Present (Gen_Par) then 9929 Prepend_Elmt (Inst_Par, Ancestors); 9930 9931 else 9932 -- Parent is not the name of an instantiation 9933 9934 Install_Noninstance_Specs (Inst_Par); 9935 exit; 9936 end if; 9937 9938 else 9939 -- Previous error 9940 9941 exit; 9942 end if; 9943 end loop; 9944 9945 if Present (First_Gen) then 9946 Append_Elmt (First_Par, Ancestors); 9947 else 9948 Install_Noninstance_Specs (First_Par); 9949 end if; 9950 9951 if not Is_Empty_Elmt_List (Ancestors) then 9952 Elmt := First_Elmt (Ancestors); 9953 while Present (Elmt) loop 9954 Install_Spec (Node (Elmt)); 9955 Install_Formal_Packages (Node (Elmt)); 9956 Next_Elmt (Elmt); 9957 end loop; 9958 end if; 9959 9960 if not In_Body then 9961 Push_Scope (S); 9962 end if; 9963 end Install_Parent; 9964 9965 ------------------------------- 9966 -- Install_Hidden_Primitives -- 9967 ------------------------------- 9968 9969 procedure Install_Hidden_Primitives 9970 (Prims_List : in out Elist_Id; 9971 Gen_T : Entity_Id; 9972 Act_T : Entity_Id) 9973 is 9974 Elmt : Elmt_Id; 9975 List : Elist_Id := No_Elist; 9976 Prim_G_Elmt : Elmt_Id; 9977 Prim_A_Elmt : Elmt_Id; 9978 Prim_G : Node_Id; 9979 Prim_A : Node_Id; 9980 9981 begin 9982 -- No action needed in case of serious errors because we cannot trust 9983 -- in the order of primitives 9984 9985 if Serious_Errors_Detected > 0 then 9986 return; 9987 9988 -- No action possible if we don't have available the list of primitive 9989 -- operations 9990 9991 elsif No (Gen_T) 9992 or else not Is_Record_Type (Gen_T) 9993 or else not Is_Tagged_Type (Gen_T) 9994 or else not Is_Record_Type (Act_T) 9995 or else not Is_Tagged_Type (Act_T) 9996 then 9997 return; 9998 9999 -- There is no need to handle interface types since their primitives 10000 -- cannot be hidden 10001 10002 elsif Is_Interface (Gen_T) then 10003 return; 10004 end if; 10005 10006 Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); 10007 10008 if not Is_Class_Wide_Type (Act_T) then 10009 Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); 10010 else 10011 Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); 10012 end if; 10013 10014 loop 10015 -- Skip predefined primitives in the generic formal 10016 10017 while Present (Prim_G_Elmt) 10018 and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) 10019 loop 10020 Next_Elmt (Prim_G_Elmt); 10021 end loop; 10022 10023 -- Skip predefined primitives in the generic actual 10024 10025 while Present (Prim_A_Elmt) 10026 and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) 10027 loop 10028 Next_Elmt (Prim_A_Elmt); 10029 end loop; 10030 10031 exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); 10032 10033 Prim_G := Node (Prim_G_Elmt); 10034 Prim_A := Node (Prim_A_Elmt); 10035 10036 -- There is no need to handle interface primitives because their 10037 -- primitives are not hidden 10038 10039 exit when Present (Interface_Alias (Prim_G)); 10040 10041 -- Here we install one hidden primitive 10042 10043 if Chars (Prim_G) /= Chars (Prim_A) 10044 and then Has_Suffix (Prim_A, 'P') 10045 and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) 10046 then 10047 Set_Chars (Prim_A, Chars (Prim_G)); 10048 Append_New_Elmt (Prim_A, To => List); 10049 end if; 10050 10051 Next_Elmt (Prim_A_Elmt); 10052 Next_Elmt (Prim_G_Elmt); 10053 end loop; 10054 10055 -- Append the elements to the list of temporarily visible primitives 10056 -- avoiding duplicates. 10057 10058 if Present (List) then 10059 if No (Prims_List) then 10060 Prims_List := New_Elmt_List; 10061 end if; 10062 10063 Elmt := First_Elmt (List); 10064 while Present (Elmt) loop 10065 Append_Unique_Elmt (Node (Elmt), Prims_List); 10066 Next_Elmt (Elmt); 10067 end loop; 10068 end if; 10069 end Install_Hidden_Primitives; 10070 10071 ------------------------------- 10072 -- Restore_Hidden_Primitives -- 10073 ------------------------------- 10074 10075 procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is 10076 Prim_Elmt : Elmt_Id; 10077 Prim : Node_Id; 10078 10079 begin 10080 if Prims_List /= No_Elist then 10081 Prim_Elmt := First_Elmt (Prims_List); 10082 while Present (Prim_Elmt) loop 10083 Prim := Node (Prim_Elmt); 10084 Set_Chars (Prim, Add_Suffix (Prim, 'P')); 10085 Next_Elmt (Prim_Elmt); 10086 end loop; 10087 10088 Prims_List := No_Elist; 10089 end if; 10090 end Restore_Hidden_Primitives; 10091 10092 -------------------------------- 10093 -- Instantiate_Formal_Package -- 10094 -------------------------------- 10095 10096 function Instantiate_Formal_Package 10097 (Formal : Node_Id; 10098 Actual : Node_Id; 10099 Analyzed_Formal : Node_Id) return List_Id 10100 is 10101 Loc : constant Source_Ptr := Sloc (Actual); 10102 Hidden_Formals : constant Elist_Id := New_Elmt_List; 10103 Actual_Pack : Entity_Id; 10104 Formal_Pack : Entity_Id; 10105 Gen_Parent : Entity_Id; 10106 Decls : List_Id; 10107 Nod : Node_Id; 10108 Parent_Spec : Node_Id; 10109 10110 procedure Find_Matching_Actual 10111 (F : Node_Id; 10112 Act : in out Entity_Id); 10113 -- We need to associate each formal entity in the formal package with 10114 -- the corresponding entity in the actual package. The actual package 10115 -- has been analyzed and possibly expanded, and as a result there is 10116 -- no one-to-one correspondence between the two lists (for example, 10117 -- the actual may include subtypes, itypes, and inherited primitive 10118 -- operations, interspersed among the renaming declarations for the 10119 -- actuals). We retrieve the corresponding actual by name because each 10120 -- actual has the same name as the formal, and they do appear in the 10121 -- same order. 10122 10123 function Get_Formal_Entity (N : Node_Id) return Entity_Id; 10124 -- Retrieve entity of defining entity of generic formal parameter. 10125 -- Only the declarations of formals need to be considered when 10126 -- linking them to actuals, but the declarative list may include 10127 -- internal entities generated during analysis, and those are ignored. 10128 10129 procedure Match_Formal_Entity 10130 (Formal_Node : Node_Id; 10131 Formal_Ent : Entity_Id; 10132 Actual_Ent : Entity_Id); 10133 -- Associates the formal entity with the actual. In the case where 10134 -- Formal_Ent is a formal package, this procedure iterates through all 10135 -- of its formals and enters associations between the actuals occurring 10136 -- in the formal package's corresponding actual package (given by 10137 -- Actual_Ent) and the formal package's formal parameters. This 10138 -- procedure recurses if any of the parameters is itself a package. 10139 10140 function Is_Instance_Of 10141 (Act_Spec : Entity_Id; 10142 Gen_Anc : Entity_Id) return Boolean; 10143 -- The actual can be an instantiation of a generic within another 10144 -- instance, in which case there is no direct link from it to the 10145 -- original generic ancestor. In that case, we recognize that the 10146 -- ultimate ancestor is the same by examining names and scopes. 10147 10148 procedure Process_Nested_Formal (Formal : Entity_Id); 10149 -- If the current formal is declared with a box, its own formals are 10150 -- visible in the instance, as they were in the generic, and their 10151 -- Hidden flag must be reset. If some of these formals are themselves 10152 -- packages declared with a box, the processing must be recursive. 10153 10154 -------------------------- 10155 -- Find_Matching_Actual -- 10156 -------------------------- 10157 10158 procedure Find_Matching_Actual 10159 (F : Node_Id; 10160 Act : in out Entity_Id) 10161 is 10162 Formal_Ent : Entity_Id; 10163 10164 begin 10165 case Nkind (Original_Node (F)) is 10166 when N_Formal_Object_Declaration 10167 | N_Formal_Type_Declaration 10168 => 10169 Formal_Ent := Defining_Identifier (F); 10170 10171 while Chars (Act) /= Chars (Formal_Ent) loop 10172 Next_Entity (Act); 10173 end loop; 10174 10175 when N_Formal_Package_Declaration 10176 | N_Formal_Subprogram_Declaration 10177 | N_Generic_Package_Declaration 10178 | N_Package_Declaration 10179 => 10180 Formal_Ent := Defining_Entity (F); 10181 10182 while Chars (Act) /= Chars (Formal_Ent) loop 10183 Next_Entity (Act); 10184 end loop; 10185 10186 when others => 10187 raise Program_Error; 10188 end case; 10189 end Find_Matching_Actual; 10190 10191 ------------------------- 10192 -- Match_Formal_Entity -- 10193 ------------------------- 10194 10195 procedure Match_Formal_Entity 10196 (Formal_Node : Node_Id; 10197 Formal_Ent : Entity_Id; 10198 Actual_Ent : Entity_Id) 10199 is 10200 Act_Pkg : Entity_Id; 10201 10202 begin 10203 Set_Instance_Of (Formal_Ent, Actual_Ent); 10204 10205 if Ekind (Actual_Ent) = E_Package then 10206 10207 -- Record associations for each parameter 10208 10209 Act_Pkg := Actual_Ent; 10210 10211 declare 10212 A_Ent : Entity_Id := First_Entity (Act_Pkg); 10213 F_Ent : Entity_Id; 10214 F_Node : Node_Id; 10215 10216 Gen_Decl : Node_Id; 10217 Formals : List_Id; 10218 Actual : Entity_Id; 10219 10220 begin 10221 -- Retrieve the actual given in the formal package declaration 10222 10223 Actual := Entity (Name (Original_Node (Formal_Node))); 10224 10225 -- The actual in the formal package declaration may be a 10226 -- renamed generic package, in which case we want to retrieve 10227 -- the original generic in order to traverse its formal part. 10228 10229 if Present (Renamed_Entity (Actual)) then 10230 Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual)); 10231 else 10232 Gen_Decl := Unit_Declaration_Node (Actual); 10233 end if; 10234 10235 Formals := Generic_Formal_Declarations (Gen_Decl); 10236 10237 if Present (Formals) then 10238 F_Node := First_Non_Pragma (Formals); 10239 else 10240 F_Node := Empty; 10241 end if; 10242 10243 while Present (A_Ent) 10244 and then Present (F_Node) 10245 and then A_Ent /= First_Private_Entity (Act_Pkg) 10246 loop 10247 F_Ent := Get_Formal_Entity (F_Node); 10248 10249 if Present (F_Ent) then 10250 10251 -- This is a formal of the original package. Record 10252 -- association and recurse. 10253 10254 Find_Matching_Actual (F_Node, A_Ent); 10255 Match_Formal_Entity (F_Node, F_Ent, A_Ent); 10256 Next_Entity (A_Ent); 10257 end if; 10258 10259 Next_Non_Pragma (F_Node); 10260 end loop; 10261 end; 10262 end if; 10263 end Match_Formal_Entity; 10264 10265 ----------------------- 10266 -- Get_Formal_Entity -- 10267 ----------------------- 10268 10269 function Get_Formal_Entity (N : Node_Id) return Entity_Id is 10270 Kind : constant Node_Kind := Nkind (Original_Node (N)); 10271 begin 10272 case Kind is 10273 when N_Formal_Object_Declaration => 10274 return Defining_Identifier (N); 10275 10276 when N_Formal_Type_Declaration => 10277 return Defining_Identifier (N); 10278 10279 when N_Formal_Subprogram_Declaration => 10280 return Defining_Unit_Name (Specification (N)); 10281 10282 when N_Formal_Package_Declaration => 10283 return Defining_Identifier (Original_Node (N)); 10284 10285 when N_Generic_Package_Declaration => 10286 return Defining_Identifier (Original_Node (N)); 10287 10288 -- All other declarations are introduced by semantic analysis and 10289 -- have no match in the actual. 10290 10291 when others => 10292 return Empty; 10293 end case; 10294 end Get_Formal_Entity; 10295 10296 -------------------- 10297 -- Is_Instance_Of -- 10298 -------------------- 10299 10300 function Is_Instance_Of 10301 (Act_Spec : Entity_Id; 10302 Gen_Anc : Entity_Id) return Boolean 10303 is 10304 Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); 10305 10306 begin 10307 if No (Gen_Par) then 10308 return False; 10309 10310 -- Simplest case: the generic parent of the actual is the formal 10311 10312 elsif Gen_Par = Gen_Anc then 10313 return True; 10314 10315 elsif Chars (Gen_Par) /= Chars (Gen_Anc) then 10316 return False; 10317 10318 -- The actual may be obtained through several instantiations. Its 10319 -- scope must itself be an instance of a generic declared in the 10320 -- same scope as the formal. Any other case is detected above. 10321 10322 elsif not Is_Generic_Instance (Scope (Gen_Par)) then 10323 return False; 10324 10325 else 10326 return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc); 10327 end if; 10328 end Is_Instance_Of; 10329 10330 --------------------------- 10331 -- Process_Nested_Formal -- 10332 --------------------------- 10333 10334 procedure Process_Nested_Formal (Formal : Entity_Id) is 10335 Ent : Entity_Id; 10336 10337 begin 10338 if Present (Associated_Formal_Package (Formal)) 10339 and then Box_Present (Parent (Associated_Formal_Package (Formal))) 10340 then 10341 Ent := First_Entity (Formal); 10342 while Present (Ent) loop 10343 Set_Is_Hidden (Ent, False); 10344 Set_Is_Visible_Formal (Ent); 10345 Set_Is_Potentially_Use_Visible 10346 (Ent, Is_Potentially_Use_Visible (Formal)); 10347 10348 if Ekind (Ent) = E_Package then 10349 exit when Renamed_Entity (Ent) = Renamed_Entity (Formal); 10350 Process_Nested_Formal (Ent); 10351 end if; 10352 10353 Next_Entity (Ent); 10354 end loop; 10355 end if; 10356 end Process_Nested_Formal; 10357 10358 -- Start of processing for Instantiate_Formal_Package 10359 10360 begin 10361 Analyze (Actual); 10362 10363 -- The actual must be a package instance, or else a current instance 10364 -- such as a parent generic within the body of a generic child. 10365 10366 if not Is_Entity_Name (Actual) 10367 or else not Ekind_In (Entity (Actual), E_Generic_Package, E_Package) 10368 then 10369 Error_Msg_N 10370 ("expect package instance to instantiate formal", Actual); 10371 Abandon_Instantiation (Actual); 10372 raise Program_Error; 10373 10374 else 10375 Actual_Pack := Entity (Actual); 10376 Set_Is_Instantiated (Actual_Pack); 10377 10378 -- The actual may be a renamed package, or an outer generic formal 10379 -- package whose instantiation is converted into a renaming. 10380 10381 if Present (Renamed_Object (Actual_Pack)) then 10382 Actual_Pack := Renamed_Object (Actual_Pack); 10383 end if; 10384 10385 if Nkind (Analyzed_Formal) = N_Formal_Package_Declaration then 10386 Gen_Parent := Get_Instance_Of (Entity (Name (Analyzed_Formal))); 10387 Formal_Pack := Defining_Identifier (Analyzed_Formal); 10388 else 10389 Gen_Parent := 10390 Generic_Parent (Specification (Analyzed_Formal)); 10391 Formal_Pack := 10392 Defining_Unit_Name (Specification (Analyzed_Formal)); 10393 end if; 10394 10395 if Nkind (Parent (Actual_Pack)) = N_Defining_Program_Unit_Name then 10396 Parent_Spec := Package_Specification (Actual_Pack); 10397 else 10398 Parent_Spec := Parent (Actual_Pack); 10399 end if; 10400 10401 if Gen_Parent = Any_Id then 10402 Error_Msg_N 10403 ("previous error in declaration of formal package", Actual); 10404 Abandon_Instantiation (Actual); 10405 10406 elsif Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) then 10407 null; 10408 10409 -- If this is the current instance of an enclosing generic, that unit 10410 -- is the generic package we need. 10411 10412 elsif In_Open_Scopes (Actual_Pack) 10413 and then Ekind (Actual_Pack) = E_Generic_Package 10414 then 10415 null; 10416 10417 else 10418 Error_Msg_NE 10419 ("actual parameter must be instance of&", Actual, Gen_Parent); 10420 Abandon_Instantiation (Actual); 10421 end if; 10422 10423 Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); 10424 Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); 10425 10426 Nod := 10427 Make_Package_Renaming_Declaration (Loc, 10428 Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)), 10429 Name => New_Occurrence_Of (Actual_Pack, Loc)); 10430 10431 Set_Associated_Formal_Package 10432 (Defining_Unit_Name (Nod), Defining_Identifier (Formal)); 10433 Decls := New_List (Nod); 10434 10435 -- If the formal F has a box, then the generic declarations are 10436 -- visible in the generic G. In an instance of G, the corresponding 10437 -- entities in the actual for F (which are the actuals for the 10438 -- instantiation of the generic that F denotes) must also be made 10439 -- visible for analysis of the current instance. On exit from the 10440 -- current instance, those entities are made private again. If the 10441 -- actual is currently in use, these entities are also use-visible. 10442 10443 -- The loop through the actual entities also steps through the formal 10444 -- entities and enters associations from formals to actuals into the 10445 -- renaming map. This is necessary to properly handle checking of 10446 -- actual parameter associations for later formals that depend on 10447 -- actuals declared in the formal package. 10448 10449 -- In Ada 2005, partial parameterization requires that we make 10450 -- visible the actuals corresponding to formals that were defaulted 10451 -- in the formal package. There formals are identified because they 10452 -- remain formal generics within the formal package, rather than 10453 -- being renamings of the actuals supplied. 10454 10455 declare 10456 Gen_Decl : constant Node_Id := 10457 Unit_Declaration_Node (Gen_Parent); 10458 Formals : constant List_Id := 10459 Generic_Formal_Declarations (Gen_Decl); 10460 10461 Actual_Ent : Entity_Id; 10462 Actual_Of_Formal : Node_Id; 10463 Formal_Node : Node_Id; 10464 Formal_Ent : Entity_Id; 10465 10466 begin 10467 if Present (Formals) then 10468 Formal_Node := First_Non_Pragma (Formals); 10469 else 10470 Formal_Node := Empty; 10471 end if; 10472 10473 Actual_Ent := First_Entity (Actual_Pack); 10474 Actual_Of_Formal := 10475 First (Visible_Declarations (Specification (Analyzed_Formal))); 10476 while Present (Actual_Ent) 10477 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10478 loop 10479 if Present (Formal_Node) then 10480 Formal_Ent := Get_Formal_Entity (Formal_Node); 10481 10482 if Present (Formal_Ent) then 10483 Find_Matching_Actual (Formal_Node, Actual_Ent); 10484 Match_Formal_Entity (Formal_Node, Formal_Ent, Actual_Ent); 10485 10486 -- We iterate at the same time over the actuals of the 10487 -- local package created for the formal, to determine 10488 -- which one of the formals of the original generic were 10489 -- defaulted in the formal. The corresponding actual 10490 -- entities are visible in the enclosing instance. 10491 10492 if Box_Present (Formal) 10493 or else 10494 (Present (Actual_Of_Formal) 10495 and then 10496 Is_Generic_Formal 10497 (Get_Formal_Entity (Actual_Of_Formal))) 10498 then 10499 Set_Is_Hidden (Actual_Ent, False); 10500 Set_Is_Visible_Formal (Actual_Ent); 10501 Set_Is_Potentially_Use_Visible 10502 (Actual_Ent, In_Use (Actual_Pack)); 10503 10504 if Ekind (Actual_Ent) = E_Package then 10505 Process_Nested_Formal (Actual_Ent); 10506 end if; 10507 10508 else 10509 if not Is_Hidden (Actual_Ent) then 10510 Append_Elmt (Actual_Ent, Hidden_Formals); 10511 end if; 10512 10513 Set_Is_Hidden (Actual_Ent); 10514 Set_Is_Potentially_Use_Visible (Actual_Ent, False); 10515 end if; 10516 end if; 10517 10518 Next_Non_Pragma (Formal_Node); 10519 Next (Actual_Of_Formal); 10520 10521 else 10522 -- No further formals to match, but the generic part may 10523 -- contain inherited operation that are not hidden in the 10524 -- enclosing instance. 10525 10526 Next_Entity (Actual_Ent); 10527 end if; 10528 end loop; 10529 10530 -- Inherited subprograms generated by formal derived types are 10531 -- also visible if the types are. 10532 10533 Actual_Ent := First_Entity (Actual_Pack); 10534 while Present (Actual_Ent) 10535 and then Actual_Ent /= First_Private_Entity (Actual_Pack) 10536 loop 10537 if Is_Overloadable (Actual_Ent) 10538 and then 10539 Nkind (Parent (Actual_Ent)) = N_Subtype_Declaration 10540 and then 10541 not Is_Hidden (Defining_Identifier (Parent (Actual_Ent))) 10542 then 10543 Set_Is_Hidden (Actual_Ent, False); 10544 Set_Is_Potentially_Use_Visible 10545 (Actual_Ent, In_Use (Actual_Pack)); 10546 end if; 10547 10548 Next_Entity (Actual_Ent); 10549 end loop; 10550 10551 -- No conformance to check if the generic has no formal parameters 10552 -- and the formal package has no generic associations. 10553 10554 if Is_Empty_List (Formals) 10555 and then 10556 (Box_Present (Formal) 10557 or else No (Generic_Associations (Formal))) 10558 then 10559 return Decls; 10560 end if; 10561 end; 10562 10563 -- If the formal is not declared with a box, reanalyze it as an 10564 -- abbreviated instantiation, to verify the matching rules of 12.7. 10565 -- The actual checks are performed after the generic associations 10566 -- have been analyzed, to guarantee the same visibility for this 10567 -- instantiation and for the actuals. 10568 10569 -- In Ada 2005, the generic associations for the formal can include 10570 -- defaulted parameters. These are ignored during check. This 10571 -- internal instantiation is removed from the tree after conformance 10572 -- checking, because it contains formal declarations for those 10573 -- defaulted parameters, and those should not reach the back-end. 10574 10575 if not Box_Present (Formal) then 10576 declare 10577 I_Pack : constant Entity_Id := 10578 Make_Temporary (Sloc (Actual), 'P'); 10579 10580 begin 10581 Set_Is_Internal (I_Pack); 10582 Set_Ekind (I_Pack, E_Package); 10583 Set_Hidden_In_Formal_Instance (I_Pack, Hidden_Formals); 10584 10585 Append_To (Decls, 10586 Make_Package_Instantiation (Sloc (Actual), 10587 Defining_Unit_Name => I_Pack, 10588 Name => 10589 New_Occurrence_Of 10590 (Get_Instance_Of (Gen_Parent), Sloc (Actual)), 10591 Generic_Associations => Generic_Associations (Formal))); 10592 end; 10593 end if; 10594 10595 return Decls; 10596 end if; 10597 end Instantiate_Formal_Package; 10598 10599 ----------------------------------- 10600 -- Instantiate_Formal_Subprogram -- 10601 ----------------------------------- 10602 10603 function Instantiate_Formal_Subprogram 10604 (Formal : Node_Id; 10605 Actual : Node_Id; 10606 Analyzed_Formal : Node_Id) return Node_Id 10607 is 10608 Analyzed_S : constant Entity_Id := 10609 Defining_Unit_Name (Specification (Analyzed_Formal)); 10610 Formal_Sub : constant Entity_Id := 10611 Defining_Unit_Name (Specification (Formal)); 10612 10613 function From_Parent_Scope (Subp : Entity_Id) return Boolean; 10614 -- If the generic is a child unit, the parent has been installed on the 10615 -- scope stack, but a default subprogram cannot resolve to something 10616 -- on the parent because that parent is not really part of the visible 10617 -- context (it is there to resolve explicit local entities). If the 10618 -- default has resolved in this way, we remove the entity from immediate 10619 -- visibility and analyze the node again to emit an error message or 10620 -- find another visible candidate. 10621 10622 procedure Valid_Actual_Subprogram (Act : Node_Id); 10623 -- Perform legality check and raise exception on failure 10624 10625 ----------------------- 10626 -- From_Parent_Scope -- 10627 ----------------------- 10628 10629 function From_Parent_Scope (Subp : Entity_Id) return Boolean is 10630 Gen_Scope : Node_Id; 10631 10632 begin 10633 Gen_Scope := Scope (Analyzed_S); 10634 while Present (Gen_Scope) and then Is_Child_Unit (Gen_Scope) loop 10635 if Scope (Subp) = Scope (Gen_Scope) then 10636 return True; 10637 end if; 10638 10639 Gen_Scope := Scope (Gen_Scope); 10640 end loop; 10641 10642 return False; 10643 end From_Parent_Scope; 10644 10645 ----------------------------- 10646 -- Valid_Actual_Subprogram -- 10647 ----------------------------- 10648 10649 procedure Valid_Actual_Subprogram (Act : Node_Id) is 10650 Act_E : Entity_Id; 10651 10652 begin 10653 if Is_Entity_Name (Act) then 10654 Act_E := Entity (Act); 10655 10656 elsif Nkind (Act) = N_Selected_Component 10657 and then Is_Entity_Name (Selector_Name (Act)) 10658 then 10659 Act_E := Entity (Selector_Name (Act)); 10660 10661 else 10662 Act_E := Empty; 10663 end if; 10664 10665 if (Present (Act_E) and then Is_Overloadable (Act_E)) 10666 or else Nkind_In (Act, N_Attribute_Reference, 10667 N_Indexed_Component, 10668 N_Character_Literal, 10669 N_Explicit_Dereference) 10670 then 10671 return; 10672 end if; 10673 10674 Error_Msg_NE 10675 ("expect subprogram or entry name in instantiation of &", 10676 Instantiation_Node, Formal_Sub); 10677 Abandon_Instantiation (Instantiation_Node); 10678 end Valid_Actual_Subprogram; 10679 10680 -- Local variables 10681 10682 Decl_Node : Node_Id; 10683 Loc : Source_Ptr; 10684 Nam : Node_Id; 10685 New_Spec : Node_Id; 10686 New_Subp : Entity_Id; 10687 10688 -- Start of processing for Instantiate_Formal_Subprogram 10689 10690 begin 10691 New_Spec := New_Copy_Tree (Specification (Formal)); 10692 10693 -- The tree copy has created the proper instantiation sloc for the 10694 -- new specification. Use this location for all other constructed 10695 -- declarations. 10696 10697 Loc := Sloc (Defining_Unit_Name (New_Spec)); 10698 10699 -- Create new entity for the actual (New_Copy_Tree does not), and 10700 -- indicate that it is an actual. 10701 10702 New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); 10703 Set_Ekind (New_Subp, Ekind (Analyzed_S)); 10704 Set_Is_Generic_Actual_Subprogram (New_Subp); 10705 Set_Defining_Unit_Name (New_Spec, New_Subp); 10706 10707 -- Create new entities for the each of the formals in the specification 10708 -- of the renaming declaration built for the actual. 10709 10710 if Present (Parameter_Specifications (New_Spec)) then 10711 declare 10712 F : Node_Id; 10713 F_Id : Entity_Id; 10714 10715 begin 10716 F := First (Parameter_Specifications (New_Spec)); 10717 while Present (F) loop 10718 F_Id := Defining_Identifier (F); 10719 10720 Set_Defining_Identifier (F, 10721 Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id))); 10722 Next (F); 10723 end loop; 10724 end; 10725 end if; 10726 10727 -- Find entity of actual. If the actual is an attribute reference, it 10728 -- cannot be resolved here (its formal is missing) but is handled 10729 -- instead in Attribute_Renaming. If the actual is overloaded, it is 10730 -- fully resolved subsequently, when the renaming declaration for the 10731 -- formal is analyzed. If it is an explicit dereference, resolve the 10732 -- prefix but not the actual itself, to prevent interpretation as call. 10733 10734 if Present (Actual) then 10735 Loc := Sloc (Actual); 10736 Set_Sloc (New_Spec, Loc); 10737 10738 if Nkind (Actual) = N_Operator_Symbol then 10739 Find_Direct_Name (Actual); 10740 10741 elsif Nkind (Actual) = N_Explicit_Dereference then 10742 Analyze (Prefix (Actual)); 10743 10744 elsif Nkind (Actual) /= N_Attribute_Reference then 10745 Analyze (Actual); 10746 end if; 10747 10748 Valid_Actual_Subprogram (Actual); 10749 Nam := Actual; 10750 10751 elsif Present (Default_Name (Formal)) then 10752 if not Nkind_In (Default_Name (Formal), N_Attribute_Reference, 10753 N_Selected_Component, 10754 N_Indexed_Component, 10755 N_Character_Literal) 10756 and then Present (Entity (Default_Name (Formal))) 10757 then 10758 Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc); 10759 else 10760 Nam := New_Copy (Default_Name (Formal)); 10761 Set_Sloc (Nam, Loc); 10762 end if; 10763 10764 elsif Box_Present (Formal) then 10765 10766 -- Actual is resolved at the point of instantiation. Create an 10767 -- identifier or operator with the same name as the formal. 10768 10769 if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then 10770 Nam := 10771 Make_Operator_Symbol (Loc, 10772 Chars => Chars (Formal_Sub), 10773 Strval => No_String); 10774 else 10775 Nam := Make_Identifier (Loc, Chars (Formal_Sub)); 10776 end if; 10777 10778 elsif Nkind (Specification (Formal)) = N_Procedure_Specification 10779 and then Null_Present (Specification (Formal)) 10780 then 10781 -- Generate null body for procedure, for use in the instance 10782 10783 Decl_Node := 10784 Make_Subprogram_Body (Loc, 10785 Specification => New_Spec, 10786 Declarations => New_List, 10787 Handled_Statement_Sequence => 10788 Make_Handled_Sequence_Of_Statements (Loc, 10789 Statements => New_List (Make_Null_Statement (Loc)))); 10790 10791 Set_Is_Intrinsic_Subprogram (Defining_Unit_Name (New_Spec)); 10792 return Decl_Node; 10793 10794 else 10795 Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); 10796 Error_Msg_NE 10797 ("missing actual&", Instantiation_Node, Formal_Sub); 10798 Error_Msg_NE 10799 ("\in instantiation of & declared#", 10800 Instantiation_Node, Scope (Analyzed_S)); 10801 Abandon_Instantiation (Instantiation_Node); 10802 end if; 10803 10804 Decl_Node := 10805 Make_Subprogram_Renaming_Declaration (Loc, 10806 Specification => New_Spec, 10807 Name => Nam); 10808 10809 -- If we do not have an actual and the formal specified <> then set to 10810 -- get proper default. 10811 10812 if No (Actual) and then Box_Present (Formal) then 10813 Set_From_Default (Decl_Node); 10814 end if; 10815 10816 -- Gather possible interpretations for the actual before analyzing the 10817 -- instance. If overloaded, it will be resolved when analyzing the 10818 -- renaming declaration. 10819 10820 if Box_Present (Formal) and then No (Actual) then 10821 Analyze (Nam); 10822 10823 if Is_Child_Unit (Scope (Analyzed_S)) 10824 and then Present (Entity (Nam)) 10825 then 10826 if not Is_Overloaded (Nam) then 10827 if From_Parent_Scope (Entity (Nam)) then 10828 Set_Is_Immediately_Visible (Entity (Nam), False); 10829 Set_Entity (Nam, Empty); 10830 Set_Etype (Nam, Empty); 10831 10832 Analyze (Nam); 10833 Set_Is_Immediately_Visible (Entity (Nam)); 10834 end if; 10835 10836 else 10837 declare 10838 I : Interp_Index; 10839 It : Interp; 10840 10841 begin 10842 Get_First_Interp (Nam, I, It); 10843 while Present (It.Nam) loop 10844 if From_Parent_Scope (It.Nam) then 10845 Remove_Interp (I); 10846 end if; 10847 10848 Get_Next_Interp (I, It); 10849 end loop; 10850 end; 10851 end if; 10852 end if; 10853 end if; 10854 10855 -- The generic instantiation freezes the actual. This can only be done 10856 -- once the actual is resolved, in the analysis of the renaming 10857 -- declaration. To make the formal subprogram entity available, we set 10858 -- Corresponding_Formal_Spec to point to the formal subprogram entity. 10859 -- This is also needed in Analyze_Subprogram_Renaming for the processing 10860 -- of formal abstract subprograms. 10861 10862 Set_Corresponding_Formal_Spec (Decl_Node, Analyzed_S); 10863 10864 -- We cannot analyze the renaming declaration, and thus find the actual, 10865 -- until all the actuals are assembled in the instance. For subsequent 10866 -- checks of other actuals, indicate the node that will hold the 10867 -- instance of this formal. 10868 10869 Set_Instance_Of (Analyzed_S, Nam); 10870 10871 if Nkind (Actual) = N_Selected_Component 10872 and then Is_Task_Type (Etype (Prefix (Actual))) 10873 and then not Is_Frozen (Etype (Prefix (Actual))) 10874 then 10875 -- The renaming declaration will create a body, which must appear 10876 -- outside of the instantiation, We move the renaming declaration 10877 -- out of the instance, and create an additional renaming inside, 10878 -- to prevent freezing anomalies. 10879 10880 declare 10881 Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); 10882 10883 begin 10884 Set_Defining_Unit_Name (New_Spec, Anon_Id); 10885 Insert_Before (Instantiation_Node, Decl_Node); 10886 Analyze (Decl_Node); 10887 10888 -- Now create renaming within the instance 10889 10890 Decl_Node := 10891 Make_Subprogram_Renaming_Declaration (Loc, 10892 Specification => New_Copy_Tree (New_Spec), 10893 Name => New_Occurrence_Of (Anon_Id, Loc)); 10894 10895 Set_Defining_Unit_Name (Specification (Decl_Node), 10896 Make_Defining_Identifier (Loc, Chars (Formal_Sub))); 10897 end; 10898 end if; 10899 10900 return Decl_Node; 10901 end Instantiate_Formal_Subprogram; 10902 10903 ------------------------ 10904 -- Instantiate_Object -- 10905 ------------------------ 10906 10907 function Instantiate_Object 10908 (Formal : Node_Id; 10909 Actual : Node_Id; 10910 Analyzed_Formal : Node_Id) return List_Id 10911 is 10912 Gen_Obj : constant Entity_Id := Defining_Identifier (Formal); 10913 A_Gen_Obj : constant Entity_Id := 10914 Defining_Identifier (Analyzed_Formal); 10915 Acc_Def : Node_Id := Empty; 10916 Act_Assoc : constant Node_Id := Parent (Actual); 10917 Actual_Decl : Node_Id := Empty; 10918 Decl_Node : Node_Id; 10919 Def : Node_Id; 10920 Ftyp : Entity_Id; 10921 List : constant List_Id := New_List; 10922 Loc : constant Source_Ptr := Sloc (Actual); 10923 Orig_Ftyp : constant Entity_Id := Etype (A_Gen_Obj); 10924 Subt_Decl : Node_Id := Empty; 10925 Subt_Mark : Node_Id := Empty; 10926 10927 function Copy_Access_Def return Node_Id; 10928 -- If formal is an anonymous access, copy access definition of formal 10929 -- for generated object declaration. 10930 10931 --------------------- 10932 -- Copy_Access_Def -- 10933 --------------------- 10934 10935 function Copy_Access_Def return Node_Id is 10936 begin 10937 Def := New_Copy_Tree (Acc_Def); 10938 10939 -- In addition, if formal is an access to subprogram we need to 10940 -- generate new formals for the signature of the default, so that 10941 -- the tree is properly formatted for ASIS use. 10942 10943 if Present (Access_To_Subprogram_Definition (Acc_Def)) then 10944 declare 10945 Par_Spec : Node_Id; 10946 begin 10947 Par_Spec := 10948 First (Parameter_Specifications 10949 (Access_To_Subprogram_Definition (Def))); 10950 while Present (Par_Spec) loop 10951 Set_Defining_Identifier (Par_Spec, 10952 Make_Defining_Identifier (Sloc (Acc_Def), 10953 Chars => Chars (Defining_Identifier (Par_Spec)))); 10954 Next (Par_Spec); 10955 end loop; 10956 end; 10957 end if; 10958 10959 return Def; 10960 end Copy_Access_Def; 10961 10962 -- Start of processing for Instantiate_Object 10963 10964 begin 10965 -- Formal may be an anonymous access 10966 10967 if Present (Subtype_Mark (Formal)) then 10968 Subt_Mark := Subtype_Mark (Formal); 10969 else 10970 Check_Access_Definition (Formal); 10971 Acc_Def := Access_Definition (Formal); 10972 end if; 10973 10974 -- Sloc for error message on missing actual 10975 10976 Error_Msg_Sloc := Sloc (Scope (A_Gen_Obj)); 10977 10978 if Get_Instance_Of (Gen_Obj) /= Gen_Obj then 10979 Error_Msg_N ("duplicate instantiation of generic parameter", Actual); 10980 end if; 10981 10982 Set_Parent (List, Parent (Actual)); 10983 10984 -- OUT present 10985 10986 if Out_Present (Formal) then 10987 10988 -- An IN OUT generic actual must be a name. The instantiation is a 10989 -- renaming declaration. The actual is the name being renamed. We 10990 -- use the actual directly, rather than a copy, because it is not 10991 -- used further in the list of actuals, and because a copy or a use 10992 -- of relocate_node is incorrect if the instance is nested within a 10993 -- generic. In order to simplify ASIS searches, the Generic_Parent 10994 -- field links the declaration to the generic association. 10995 10996 if No (Actual) then 10997 Error_Msg_NE 10998 ("missing actual &", 10999 Instantiation_Node, Gen_Obj); 11000 Error_Msg_NE 11001 ("\in instantiation of & declared#", 11002 Instantiation_Node, Scope (A_Gen_Obj)); 11003 Abandon_Instantiation (Instantiation_Node); 11004 end if; 11005 11006 if Present (Subt_Mark) then 11007 Decl_Node := 11008 Make_Object_Renaming_Declaration (Loc, 11009 Defining_Identifier => New_Copy (Gen_Obj), 11010 Subtype_Mark => New_Copy_Tree (Subt_Mark), 11011 Name => Actual); 11012 11013 else pragma Assert (Present (Acc_Def)); 11014 Decl_Node := 11015 Make_Object_Renaming_Declaration (Loc, 11016 Defining_Identifier => New_Copy (Gen_Obj), 11017 Access_Definition => New_Copy_Tree (Acc_Def), 11018 Name => Actual); 11019 end if; 11020 11021 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 11022 11023 -- The analysis of the actual may produce Insert_Action nodes, so 11024 -- the declaration must have a context in which to attach them. 11025 11026 Append (Decl_Node, List); 11027 Analyze (Actual); 11028 11029 -- Return if the analysis of the actual reported some error 11030 11031 if Etype (Actual) = Any_Type then 11032 return List; 11033 end if; 11034 11035 -- This check is performed here because Analyze_Object_Renaming will 11036 -- not check it when Comes_From_Source is False. Note though that the 11037 -- check for the actual being the name of an object will be performed 11038 -- in Analyze_Object_Renaming. 11039 11040 if Is_Object_Reference (Actual) 11041 and then Is_Dependent_Component_Of_Mutable_Object (Actual) 11042 then 11043 Error_Msg_N 11044 ("illegal discriminant-dependent component for in out parameter", 11045 Actual); 11046 end if; 11047 11048 -- The actual has to be resolved in order to check that it is a 11049 -- variable (due to cases such as F (1), where F returns access to 11050 -- an array, and for overloaded prefixes). 11051 11052 Ftyp := Get_Instance_Of (Etype (A_Gen_Obj)); 11053 11054 -- If the type of the formal is not itself a formal, and the current 11055 -- unit is a child unit, the formal type must be declared in a 11056 -- parent, and must be retrieved by visibility. 11057 11058 if Ftyp = Orig_Ftyp 11059 and then Is_Generic_Unit (Scope (Ftyp)) 11060 and then Is_Child_Unit (Scope (A_Gen_Obj)) 11061 then 11062 declare 11063 Temp : constant Node_Id := 11064 New_Copy_Tree (Subtype_Mark (Analyzed_Formal)); 11065 begin 11066 Set_Entity (Temp, Empty); 11067 Find_Type (Temp); 11068 Ftyp := Entity (Temp); 11069 end; 11070 end if; 11071 11072 if Is_Private_Type (Ftyp) 11073 and then not Is_Private_Type (Etype (Actual)) 11074 and then (Base_Type (Full_View (Ftyp)) = Base_Type (Etype (Actual)) 11075 or else Base_Type (Etype (Actual)) = Ftyp) 11076 then 11077 -- If the actual has the type of the full view of the formal, or 11078 -- else a non-private subtype of the formal, then the visibility 11079 -- of the formal type has changed. Add to the actuals a subtype 11080 -- declaration that will force the exchange of views in the body 11081 -- of the instance as well. 11082 11083 Subt_Decl := 11084 Make_Subtype_Declaration (Loc, 11085 Defining_Identifier => Make_Temporary (Loc, 'P'), 11086 Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); 11087 11088 Prepend (Subt_Decl, List); 11089 11090 Prepend_Elmt (Full_View (Ftyp), Exchanged_Views); 11091 Exchange_Declarations (Ftyp); 11092 end if; 11093 11094 Resolve (Actual, Ftyp); 11095 11096 if not Denotes_Variable (Actual) then 11097 Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj); 11098 11099 elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then 11100 11101 -- Ada 2005 (AI-423): For a generic formal object of mode in out, 11102 -- the type of the actual shall resolve to a specific anonymous 11103 -- access type. 11104 11105 if Ada_Version < Ada_2005 11106 or else Ekind (Base_Type (Ftyp)) /= 11107 E_Anonymous_Access_Type 11108 or else Ekind (Base_Type (Etype (Actual))) /= 11109 E_Anonymous_Access_Type 11110 then 11111 Error_Msg_NE 11112 ("type of actual does not match type of&", Actual, Gen_Obj); 11113 end if; 11114 end if; 11115 11116 Note_Possible_Modification (Actual, Sure => True); 11117 11118 -- Check for instantiation with atomic/volatile object actual for 11119 -- nonatomic/nonvolatile formal (RM C.6 (12)). 11120 11121 if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then 11122 Error_Msg_NE 11123 ("cannot instantiate nonatomic formal & of mode in out", 11124 Actual, Gen_Obj); 11125 Error_Msg_N ("\with atomic object actual (RM C.6(12))", Actual); 11126 11127 elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) 11128 then 11129 Error_Msg_NE 11130 ("cannot instantiate nonvolatile formal & of mode in out", 11131 Actual, Gen_Obj); 11132 Error_Msg_N ("\with volatile object actual (RM C.6(12))", Actual); 11133 end if; 11134 11135 -- Check for instantiation on nonatomic subcomponent of an atomic 11136 -- object in Ada 2020 (RM C.6 (13)). 11137 11138 if Ada_Version >= Ada_2020 11139 and then Is_Subcomponent_Of_Atomic_Object (Actual) 11140 and then not Is_Atomic_Object (Actual) 11141 then 11142 Error_Msg_NE 11143 ("cannot instantiate formal & of mode in out with actual", 11144 Actual, Gen_Obj); 11145 Error_Msg_N 11146 ("\nonatomic subcomponent of atomic object (RM C.6(13))", 11147 Actual); 11148 end if; 11149 11150 -- Formal in-parameter 11151 11152 else 11153 -- The instantiation of a generic formal in-parameter is constant 11154 -- declaration. The actual is the expression for that declaration. 11155 -- Its type is a full copy of the type of the formal. This may be 11156 -- an access to subprogram, for which we need to generate entities 11157 -- for the formals in the new signature. 11158 11159 if Present (Actual) then 11160 if Present (Subt_Mark) then 11161 Def := New_Copy_Tree (Subt_Mark); 11162 else pragma Assert (Present (Acc_Def)); 11163 Def := Copy_Access_Def; 11164 end if; 11165 11166 Decl_Node := 11167 Make_Object_Declaration (Loc, 11168 Defining_Identifier => New_Copy (Gen_Obj), 11169 Constant_Present => True, 11170 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11171 Object_Definition => Def, 11172 Expression => Actual); 11173 11174 Set_Corresponding_Generic_Association (Decl_Node, Act_Assoc); 11175 11176 -- A generic formal object of a tagged type is defined to be 11177 -- aliased so the new constant must also be treated as aliased. 11178 11179 if Is_Tagged_Type (Etype (A_Gen_Obj)) then 11180 Set_Aliased_Present (Decl_Node); 11181 end if; 11182 11183 Append (Decl_Node, List); 11184 11185 -- No need to repeat (pre-)analysis of some expression nodes 11186 -- already handled in Preanalyze_Actuals. 11187 11188 if Nkind (Actual) /= N_Allocator then 11189 Analyze (Actual); 11190 11191 -- Return if the analysis of the actual reported some error 11192 11193 if Etype (Actual) = Any_Type then 11194 return List; 11195 end if; 11196 end if; 11197 11198 declare 11199 Formal_Type : constant Entity_Id := Etype (A_Gen_Obj); 11200 Typ : Entity_Id; 11201 11202 begin 11203 Typ := Get_Instance_Of (Formal_Type); 11204 11205 -- If the actual appears in the current or an enclosing scope, 11206 -- use its type directly. This is relevant if it has an actual 11207 -- subtype that is distinct from its nominal one. This cannot 11208 -- be done in general because the type of the actual may 11209 -- depend on other actuals, and only be fully determined when 11210 -- the enclosing instance is analyzed. 11211 11212 if Present (Etype (Actual)) 11213 and then Is_Constr_Subt_For_U_Nominal (Etype (Actual)) 11214 then 11215 Freeze_Before (Instantiation_Node, Etype (Actual)); 11216 else 11217 Freeze_Before (Instantiation_Node, Typ); 11218 end if; 11219 11220 -- If the actual is an aggregate, perform name resolution on 11221 -- its components (the analysis of an aggregate does not do it) 11222 -- to capture local names that may be hidden if the generic is 11223 -- a child unit. 11224 11225 if Nkind (Actual) = N_Aggregate then 11226 Preanalyze_And_Resolve (Actual, Typ); 11227 end if; 11228 11229 if Is_Limited_Type (Typ) 11230 and then not OK_For_Limited_Init (Typ, Actual) 11231 then 11232 Error_Msg_N 11233 ("initialization not allowed for limited types", Actual); 11234 Explain_Limited_Type (Typ, Actual); 11235 end if; 11236 end; 11237 11238 elsif Present (Default_Expression (Formal)) then 11239 11240 -- Use default to construct declaration 11241 11242 if Present (Subt_Mark) then 11243 Def := New_Copy (Subt_Mark); 11244 else pragma Assert (Present (Acc_Def)); 11245 Def := Copy_Access_Def; 11246 end if; 11247 11248 Decl_Node := 11249 Make_Object_Declaration (Sloc (Formal), 11250 Defining_Identifier => New_Copy (Gen_Obj), 11251 Constant_Present => True, 11252 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11253 Object_Definition => Def, 11254 Expression => New_Copy_Tree 11255 (Default_Expression (Formal))); 11256 11257 Set_Corresponding_Generic_Association 11258 (Decl_Node, Expression (Decl_Node)); 11259 11260 Append (Decl_Node, List); 11261 Set_Analyzed (Expression (Decl_Node), False); 11262 11263 else 11264 Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj); 11265 Error_Msg_NE ("\in instantiation of & declared#", 11266 Instantiation_Node, Scope (A_Gen_Obj)); 11267 11268 if Is_Scalar_Type (Etype (A_Gen_Obj)) then 11269 11270 -- Create dummy constant declaration so that instance can be 11271 -- analyzed, to minimize cascaded visibility errors. 11272 11273 if Present (Subt_Mark) then 11274 Def := Subt_Mark; 11275 else pragma Assert (Present (Acc_Def)); 11276 Def := Acc_Def; 11277 end if; 11278 11279 Decl_Node := 11280 Make_Object_Declaration (Loc, 11281 Defining_Identifier => New_Copy (Gen_Obj), 11282 Constant_Present => True, 11283 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 11284 Object_Definition => New_Copy (Def), 11285 Expression => 11286 Make_Attribute_Reference (Sloc (Gen_Obj), 11287 Attribute_Name => Name_First, 11288 Prefix => New_Copy (Def))); 11289 11290 Append (Decl_Node, List); 11291 11292 else 11293 Abandon_Instantiation (Instantiation_Node); 11294 end if; 11295 end if; 11296 end if; 11297 11298 if Nkind (Actual) in N_Has_Entity then 11299 Actual_Decl := Parent (Entity (Actual)); 11300 end if; 11301 11302 -- Ada 2005 (AI-423): For a formal object declaration with a null 11303 -- exclusion or an access definition that has a null exclusion: If the 11304 -- actual matching the formal object declaration denotes a generic 11305 -- formal object of another generic unit G, and the instantiation 11306 -- containing the actual occurs within the body of G or within the body 11307 -- of a generic unit declared within the declarative region of G, then 11308 -- the declaration of the formal object of G must have a null exclusion. 11309 -- Otherwise, the subtype of the actual matching the formal object 11310 -- declaration shall exclude null. 11311 11312 if Ada_Version >= Ada_2005 11313 and then Present (Actual_Decl) 11314 and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration, 11315 N_Object_Declaration) 11316 and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration 11317 and then not Has_Null_Exclusion (Actual_Decl) 11318 and then Has_Null_Exclusion (Analyzed_Formal) 11319 then 11320 Error_Msg_Sloc := Sloc (Analyzed_Formal); 11321 Error_Msg_N 11322 ("actual must exclude null to match generic formal#", Actual); 11323 end if; 11324 11325 -- An effectively volatile object cannot be used as an actual in a 11326 -- generic instantiation (SPARK RM 7.1.3(7)). The following check is 11327 -- relevant only when SPARK_Mode is on as it is not a standard Ada 11328 -- legality rule, and also verifies that the actual is an object. 11329 11330 if SPARK_Mode = On 11331 and then Present (Actual) 11332 and then Is_Object_Reference (Actual) 11333 and then Is_Effectively_Volatile_Object (Actual) 11334 then 11335 Error_Msg_N 11336 ("volatile object cannot act as actual in generic instantiation", 11337 Actual); 11338 end if; 11339 11340 return List; 11341 end Instantiate_Object; 11342 11343 ------------------------------ 11344 -- Instantiate_Package_Body -- 11345 ------------------------------ 11346 11347 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11348 -- must be replaced by gotos which jump to the end of the routine in order 11349 -- to restore the Ghost and SPARK modes. 11350 11351 procedure Instantiate_Package_Body 11352 (Body_Info : Pending_Body_Info; 11353 Inlined_Body : Boolean := False; 11354 Body_Optional : Boolean := False) 11355 is 11356 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11357 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11358 Act_Spec : constant Node_Id := Specification (Act_Decl); 11359 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11360 Gen_Id : constant Node_Id := Name (Inst_Node); 11361 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11362 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11363 Loc : constant Source_Ptr := Sloc (Inst_Node); 11364 11365 procedure Check_Initialized_Types; 11366 -- In a generic package body, an entity of a generic private type may 11367 -- appear uninitialized. This is suspicious, unless the actual is a 11368 -- fully initialized type. 11369 11370 ----------------------------- 11371 -- Check_Initialized_Types -- 11372 ----------------------------- 11373 11374 procedure Check_Initialized_Types is 11375 Decl : Node_Id; 11376 Formal : Entity_Id; 11377 Actual : Entity_Id; 11378 Uninit_Var : Entity_Id; 11379 11380 begin 11381 Decl := First (Generic_Formal_Declarations (Gen_Decl)); 11382 while Present (Decl) loop 11383 Uninit_Var := Empty; 11384 11385 if Nkind (Decl) = N_Private_Extension_Declaration then 11386 Uninit_Var := Uninitialized_Variable (Decl); 11387 11388 elsif Nkind (Decl) = N_Formal_Type_Declaration 11389 and then Nkind (Formal_Type_Definition (Decl)) = 11390 N_Formal_Private_Type_Definition 11391 then 11392 Uninit_Var := 11393 Uninitialized_Variable (Formal_Type_Definition (Decl)); 11394 end if; 11395 11396 if Present (Uninit_Var) then 11397 Formal := Defining_Identifier (Decl); 11398 Actual := First_Entity (Act_Decl_Id); 11399 11400 -- For each formal there is a subtype declaration that renames 11401 -- the actual and has the same name as the formal. Locate the 11402 -- formal for warning message about uninitialized variables 11403 -- in the generic, for which the actual type should be a fully 11404 -- initialized type. 11405 11406 while Present (Actual) loop 11407 exit when Ekind (Actual) = E_Package 11408 and then Present (Renamed_Object (Actual)); 11409 11410 if Chars (Actual) = Chars (Formal) 11411 and then not Is_Scalar_Type (Actual) 11412 and then not Is_Fully_Initialized_Type (Actual) 11413 and then Warn_On_No_Value_Assigned 11414 then 11415 Error_Msg_Node_2 := Formal; 11416 Error_Msg_NE 11417 ("generic unit has uninitialized variable& of " 11418 & "formal private type &?v?", Actual, Uninit_Var); 11419 Error_Msg_NE 11420 ("actual type for& should be fully initialized type?v?", 11421 Actual, Formal); 11422 exit; 11423 end if; 11424 11425 Next_Entity (Actual); 11426 end loop; 11427 end if; 11428 11429 Next (Decl); 11430 end loop; 11431 end Check_Initialized_Types; 11432 11433 -- Local variables 11434 11435 -- The following constants capture the context prior to instantiating 11436 -- the package body. 11437 11438 Saved_CS : constant Config_Switches_Type := Save_Config_Switches; 11439 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11440 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 11441 Saved_ISMP : constant Boolean := 11442 Ignore_SPARK_Mode_Pragmas_In_Instance; 11443 Saved_LSST : constant Suppress_Stack_Entry_Ptr := 11444 Local_Suppress_Stack_Top; 11445 Saved_SC : constant Boolean := Style_Check; 11446 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11447 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11448 Saved_SS : constant Suppress_Record := Scope_Suppress; 11449 Saved_Warn : constant Warning_Record := Save_Warnings; 11450 11451 Act_Body : Node_Id; 11452 Act_Body_Id : Entity_Id; 11453 Act_Body_Name : Node_Id; 11454 Gen_Body : Node_Id; 11455 Gen_Body_Id : Node_Id; 11456 Par_Ent : Entity_Id := Empty; 11457 Par_Installed : Boolean := False; 11458 Par_Vis : Boolean := False; 11459 11460 Vis_Prims_List : Elist_Id := No_Elist; 11461 -- List of primitives made temporarily visible in the instantiation 11462 -- to match the visibility of the formal type. 11463 11464 -- Start of processing for Instantiate_Package_Body 11465 11466 begin 11467 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11468 11469 -- The instance body may already have been processed, as the parent of 11470 -- another instance that is inlined (Load_Parent_Of_Generic). 11471 11472 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 11473 return; 11474 end if; 11475 11476 -- The package being instantiated may be subject to pragma Ghost. Set 11477 -- the mode now to ensure that any nodes generated during instantiation 11478 -- are properly marked as Ghost. 11479 11480 Set_Ghost_Mode (Act_Decl_Id); 11481 11482 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11483 11484 -- Re-establish the state of information on which checks are suppressed. 11485 -- This information was set in Body_Info at the point of instantiation, 11486 -- and now we restore it so that the instance is compiled using the 11487 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11488 11489 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11490 Scope_Suppress := Body_Info.Scope_Suppress; 11491 11492 Restore_Config_Switches (Body_Info.Config_Switches); 11493 Restore_Warnings (Body_Info.Warnings); 11494 11495 if No (Gen_Body_Id) then 11496 11497 -- Do not look for parent of generic body if none is required. 11498 -- This may happen when the routine is called as part of the 11499 -- Pending_Instantiations processing, when nested instances 11500 -- may precede the one generated from the main unit. 11501 11502 if not Unit_Requires_Body (Defining_Entity (Gen_Decl)) 11503 and then Body_Optional 11504 then 11505 goto Leave; 11506 else 11507 Load_Parent_Of_Generic 11508 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11509 11510 -- Surprisingly enough, loading the body of the parent can cause 11511 -- the body to be instantiated and the double instantiation needs 11512 -- to be prevented in order to avoid giving bogus semantic errors. 11513 11514 -- This case can occur because of the Collect_Previous_Instances 11515 -- machinery of Load_Parent_Of_Generic, which will instantiate 11516 -- bodies that are deemed to be ahead of the body of the parent 11517 -- in the compilation unit. But the relative position of these 11518 -- bodies is computed using the mere comparison of their Sloc. 11519 11520 -- Now suppose that you have two generic packages G and H, with 11521 -- G containing a mere instantiation of H: 11522 11523 -- generic 11524 -- package H is 11525 11526 -- generic 11527 -- package Nested_G is 11528 -- ... 11529 -- end Nested_G; 11530 11531 -- end H; 11532 11533 -- with H; 11534 11535 -- generic 11536 -- package G is 11537 11538 -- package My_H is new H; 11539 11540 -- end G; 11541 11542 -- and a third package Q instantiating G and Nested_G: 11543 11544 -- with G; 11545 11546 -- package Q is 11547 11548 -- package My_G is new G; 11549 11550 -- package My_Nested_G is new My_G.My_H.Nested_G; 11551 11552 -- end Q; 11553 11554 -- The body to be instantiated is that of My_Nested_G and its 11555 -- parent is the instance My_G.My_H. This latter instantiation 11556 -- is done when My_G is analyzed, i.e. after the declarations 11557 -- of My_G and My_Nested_G have been parsed; as a result, the 11558 -- Sloc of My_G.My_H is greater than the Sloc of My_Nested_G. 11559 11560 -- Therefore loading the body of My_G.My_H will cause the body 11561 -- of My_Nested_G to be instantiated because it is deemed to be 11562 -- ahead of My_G.My_H. This means that Load_Parent_Of_Generic 11563 -- will again be invoked on My_G.My_H, but this time with the 11564 -- Collect_Previous_Instances machinery disabled, so there is 11565 -- no endless mutual recursion and things are done in order. 11566 11567 if Present (Corresponding_Body (Instance_Spec (Inst_Node))) then 11568 goto Leave; 11569 end if; 11570 11571 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11572 end if; 11573 end if; 11574 11575 -- Establish global variable for sloc adjustment and for error recovery 11576 -- In the case of an instance body for an instantiation with actuals 11577 -- from a limited view, the instance body is placed at the beginning 11578 -- of the enclosing package body: use the body entity as the source 11579 -- location for nodes of the instance body. 11580 11581 if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then 11582 declare 11583 Scop : constant Entity_Id := Scope (Act_Decl_Id); 11584 Body_Id : constant Node_Id := 11585 Corresponding_Body (Unit_Declaration_Node (Scop)); 11586 11587 begin 11588 Instantiation_Node := Body_Id; 11589 end; 11590 else 11591 Instantiation_Node := Inst_Node; 11592 end if; 11593 11594 if Present (Gen_Body_Id) then 11595 Save_Env (Gen_Unit, Act_Decl_Id); 11596 Style_Check := False; 11597 11598 -- If the context of the instance is subject to SPARK_Mode "off", the 11599 -- annotation is missing, or the body is instantiated at a later pass 11600 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11601 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11602 -- instance. 11603 11604 if SPARK_Mode /= On 11605 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11606 then 11607 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11608 end if; 11609 11610 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11611 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11612 11613 Create_Instantiation_Source 11614 (Inst_Node, Gen_Body_Id, S_Adjustment); 11615 11616 Act_Body := 11617 Copy_Generic_Node 11618 (Original_Node (Gen_Body), Empty, Instantiating => True); 11619 11620 -- Create proper (possibly qualified) defining name for the body, to 11621 -- correspond to the one in the spec. 11622 11623 Act_Body_Id := 11624 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11625 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11626 11627 -- Some attributes of spec entity are not inherited by body entity 11628 11629 Set_Handler_Records (Act_Body_Id, No_List); 11630 11631 if Nkind (Defining_Unit_Name (Act_Spec)) = 11632 N_Defining_Program_Unit_Name 11633 then 11634 Act_Body_Name := 11635 Make_Defining_Program_Unit_Name (Loc, 11636 Name => 11637 New_Copy_Tree (Name (Defining_Unit_Name (Act_Spec))), 11638 Defining_Identifier => Act_Body_Id); 11639 else 11640 Act_Body_Name := Act_Body_Id; 11641 end if; 11642 11643 Set_Defining_Unit_Name (Act_Body, Act_Body_Name); 11644 11645 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11646 Check_Generic_Actuals (Act_Decl_Id, False); 11647 Check_Initialized_Types; 11648 11649 -- Install primitives hidden at the point of the instantiation but 11650 -- visible when processing the generic formals 11651 11652 declare 11653 E : Entity_Id; 11654 11655 begin 11656 E := First_Entity (Act_Decl_Id); 11657 while Present (E) loop 11658 if Is_Type (E) 11659 and then not Is_Itype (E) 11660 and then Is_Generic_Actual_Type (E) 11661 and then Is_Tagged_Type (E) 11662 then 11663 Install_Hidden_Primitives 11664 (Prims_List => Vis_Prims_List, 11665 Gen_T => Generic_Parent_Type (Parent (E)), 11666 Act_T => E); 11667 end if; 11668 11669 Next_Entity (E); 11670 end loop; 11671 end; 11672 11673 -- If it is a child unit, make the parent instance (which is an 11674 -- instance of the parent of the generic) visible. The parent 11675 -- instance is the prefix of the name of the generic unit. 11676 11677 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 11678 and then Nkind (Gen_Id) = N_Expanded_Name 11679 then 11680 Par_Ent := Entity (Prefix (Gen_Id)); 11681 Par_Vis := Is_Immediately_Visible (Par_Ent); 11682 Install_Parent (Par_Ent, In_Body => True); 11683 Par_Installed := True; 11684 11685 elsif Is_Child_Unit (Gen_Unit) then 11686 Par_Ent := Scope (Gen_Unit); 11687 Par_Vis := Is_Immediately_Visible (Par_Ent); 11688 Install_Parent (Par_Ent, In_Body => True); 11689 Par_Installed := True; 11690 end if; 11691 11692 -- If the instantiation is a library unit, and this is the main unit, 11693 -- then build the resulting compilation unit nodes for the instance. 11694 -- If this is a compilation unit but it is not the main unit, then it 11695 -- is the body of a unit in the context, that is being compiled 11696 -- because it is encloses some inlined unit or another generic unit 11697 -- being instantiated. In that case, this body is not part of the 11698 -- current compilation, and is not attached to the tree, but its 11699 -- parent must be set for analysis. 11700 11701 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11702 11703 -- Replace instance node with body of instance, and create new 11704 -- node for corresponding instance declaration. 11705 11706 Build_Instance_Compilation_Unit_Nodes 11707 (Inst_Node, Act_Body, Act_Decl); 11708 Analyze (Inst_Node); 11709 11710 if Parent (Inst_Node) = Cunit (Main_Unit) then 11711 11712 -- If the instance is a child unit itself, then set the scope 11713 -- of the expanded body to be the parent of the instantiation 11714 -- (ensuring that the fully qualified name will be generated 11715 -- for the elaboration subprogram). 11716 11717 if Nkind (Defining_Unit_Name (Act_Spec)) = 11718 N_Defining_Program_Unit_Name 11719 then 11720 Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id)); 11721 end if; 11722 end if; 11723 11724 -- Case where instantiation is not a library unit 11725 11726 else 11727 -- If this is an early instantiation, i.e. appears textually 11728 -- before the corresponding body and must be elaborated first, 11729 -- indicate that the body instance is to be delayed. 11730 11731 Install_Body (Act_Body, Inst_Node, Gen_Body, Gen_Decl); 11732 Analyze (Act_Body); 11733 end if; 11734 11735 Inherit_Context (Gen_Body, Inst_Node); 11736 11737 -- Remove the parent instances if they have been placed on the scope 11738 -- stack to compile the body. 11739 11740 if Par_Installed then 11741 Remove_Parent (In_Body => True); 11742 11743 -- Restore the previous visibility of the parent 11744 11745 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 11746 end if; 11747 11748 Restore_Hidden_Primitives (Vis_Prims_List); 11749 Restore_Private_Views (Act_Decl_Id); 11750 11751 -- Remove the current unit from visibility if this is an instance 11752 -- that is not elaborated on the fly for inlining purposes. 11753 11754 if not Inlined_Body then 11755 Set_Is_Immediately_Visible (Act_Decl_Id, False); 11756 end if; 11757 11758 Restore_Env; 11759 11760 -- If we have no body, and the unit requires a body, then complain. This 11761 -- complaint is suppressed if we have detected other errors (since a 11762 -- common reason for missing the body is that it had errors). 11763 -- In CodePeer mode, a warning has been emitted already, no need for 11764 -- further messages. 11765 11766 elsif Unit_Requires_Body (Gen_Unit) 11767 and then not Body_Optional 11768 then 11769 if CodePeer_Mode then 11770 null; 11771 11772 elsif Serious_Errors_Detected = 0 then 11773 Error_Msg_NE 11774 ("cannot find body of generic package &", Inst_Node, Gen_Unit); 11775 11776 -- Don't attempt to perform any cleanup actions if some other error 11777 -- was already detected, since this can cause blowups. 11778 11779 else 11780 goto Leave; 11781 end if; 11782 11783 -- Case of package that does not need a body 11784 11785 else 11786 -- If the instantiation of the declaration is a library unit, rewrite 11787 -- the original package instantiation as a package declaration in the 11788 -- compilation unit node. 11789 11790 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 11791 Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node)); 11792 Rewrite (Inst_Node, Act_Decl); 11793 11794 -- Generate elaboration entity, in case spec has elaboration code. 11795 -- This cannot be done when the instance is analyzed, because it 11796 -- is not known yet whether the body exists. 11797 11798 Set_Elaboration_Entity_Required (Act_Decl_Id, False); 11799 Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id); 11800 11801 -- If the instantiation is not a library unit, then append the 11802 -- declaration to the list of implicitly generated entities, unless 11803 -- it is already a list member which means that it was already 11804 -- processed 11805 11806 elsif not Is_List_Member (Act_Decl) then 11807 Mark_Rewrite_Insertion (Act_Decl); 11808 Insert_Before (Inst_Node, Act_Decl); 11809 end if; 11810 end if; 11811 11812 <<Leave>> 11813 11814 -- Restore the context that was in effect prior to instantiating the 11815 -- package body. 11816 11817 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 11818 Local_Suppress_Stack_Top := Saved_LSST; 11819 Scope_Suppress := Saved_SS; 11820 Style_Check := Saved_SC; 11821 11822 Expander_Mode_Restore; 11823 Restore_Config_Switches (Saved_CS); 11824 Restore_Ghost_Region (Saved_GM, Saved_IGR); 11825 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 11826 Restore_Warnings (Saved_Warn); 11827 end Instantiate_Package_Body; 11828 11829 --------------------------------- 11830 -- Instantiate_Subprogram_Body -- 11831 --------------------------------- 11832 11833 -- WARNING: This routine manages Ghost and SPARK regions. Return statements 11834 -- must be replaced by gotos which jump to the end of the routine in order 11835 -- to restore the Ghost and SPARK modes. 11836 11837 procedure Instantiate_Subprogram_Body 11838 (Body_Info : Pending_Body_Info; 11839 Body_Optional : Boolean := False) 11840 is 11841 Act_Decl : constant Node_Id := Body_Info.Act_Decl; 11842 Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); 11843 Inst_Node : constant Node_Id := Body_Info.Inst_Node; 11844 Gen_Id : constant Node_Id := Name (Inst_Node); 11845 Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); 11846 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit); 11847 Loc : constant Source_Ptr := Sloc (Inst_Node); 11848 Pack_Id : constant Entity_Id := 11849 Defining_Unit_Name (Parent (Act_Decl)); 11850 11851 -- The following constants capture the context prior to instantiating 11852 -- the subprogram body. 11853 11854 Saved_CS : constant Config_Switches_Type := Save_Config_Switches; 11855 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 11856 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 11857 Saved_ISMP : constant Boolean := 11858 Ignore_SPARK_Mode_Pragmas_In_Instance; 11859 Saved_LSST : constant Suppress_Stack_Entry_Ptr := 11860 Local_Suppress_Stack_Top; 11861 Saved_SC : constant Boolean := Style_Check; 11862 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 11863 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 11864 Saved_SS : constant Suppress_Record := Scope_Suppress; 11865 Saved_Warn : constant Warning_Record := Save_Warnings; 11866 11867 Act_Body : Node_Id; 11868 Act_Body_Id : Entity_Id; 11869 Gen_Body : Node_Id; 11870 Gen_Body_Id : Node_Id; 11871 Pack_Body : Node_Id; 11872 Par_Ent : Entity_Id := Empty; 11873 Par_Installed : Boolean := False; 11874 Par_Vis : Boolean := False; 11875 Ret_Expr : Node_Id; 11876 11877 begin 11878 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11879 11880 -- Subprogram body may have been created already because of an inline 11881 -- pragma, or because of multiple elaborations of the enclosing package 11882 -- when several instances of the subprogram appear in the main unit. 11883 11884 if Present (Corresponding_Body (Act_Decl)) then 11885 return; 11886 end if; 11887 11888 -- The subprogram being instantiated may be subject to pragma Ghost. Set 11889 -- the mode now to ensure that any nodes generated during instantiation 11890 -- are properly marked as Ghost. 11891 11892 Set_Ghost_Mode (Act_Decl_Id); 11893 11894 Expander_Mode_Save_And_Set (Body_Info.Expander_Status); 11895 11896 -- Re-establish the state of information on which checks are suppressed. 11897 -- This information was set in Body_Info at the point of instantiation, 11898 -- and now we restore it so that the instance is compiled using the 11899 -- check status at the instantiation (RM 11.5(7.2/2), AI95-00224-01). 11900 11901 Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; 11902 Scope_Suppress := Body_Info.Scope_Suppress; 11903 11904 Restore_Config_Switches (Body_Info.Config_Switches); 11905 Restore_Warnings (Body_Info.Warnings); 11906 11907 if No (Gen_Body_Id) then 11908 11909 -- For imported generic subprogram, no body to compile, complete 11910 -- the spec entity appropriately. 11911 11912 if Is_Imported (Gen_Unit) then 11913 Set_Is_Imported (Act_Decl_Id); 11914 Set_First_Rep_Item (Act_Decl_Id, First_Rep_Item (Gen_Unit)); 11915 Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit)); 11916 Set_Convention (Act_Decl_Id, Convention (Gen_Unit)); 11917 Set_Has_Completion (Act_Decl_Id); 11918 goto Leave; 11919 11920 -- For other cases, compile the body 11921 11922 else 11923 Load_Parent_Of_Generic 11924 (Inst_Node, Specification (Gen_Decl), Body_Optional); 11925 Gen_Body_Id := Corresponding_Body (Gen_Decl); 11926 end if; 11927 end if; 11928 11929 Instantiation_Node := Inst_Node; 11930 11931 if Present (Gen_Body_Id) then 11932 Gen_Body := Unit_Declaration_Node (Gen_Body_Id); 11933 11934 if Nkind (Gen_Body) = N_Subprogram_Body_Stub then 11935 11936 -- Either body is not present, or context is non-expanding, as 11937 -- when compiling a subunit. Mark the instance as completed, and 11938 -- diagnose a missing body when needed. 11939 11940 if Expander_Active 11941 and then Operating_Mode = Generate_Code 11942 then 11943 Error_Msg_N ("missing proper body for instantiation", Gen_Body); 11944 end if; 11945 11946 Set_Has_Completion (Act_Decl_Id); 11947 goto Leave; 11948 end if; 11949 11950 Save_Env (Gen_Unit, Act_Decl_Id); 11951 Style_Check := False; 11952 11953 -- If the context of the instance is subject to SPARK_Mode "off", the 11954 -- annotation is missing, or the body is instantiated at a later pass 11955 -- and its spec ignored SPARK_Mode pragma, set the global flag which 11956 -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within the 11957 -- instance. 11958 11959 if SPARK_Mode /= On 11960 or else Ignore_SPARK_Mode_Pragmas (Act_Decl_Id) 11961 then 11962 Ignore_SPARK_Mode_Pragmas_In_Instance := True; 11963 end if; 11964 11965 -- If the context of an instance is not subject to SPARK_Mode "off", 11966 -- and the generic body is subject to an explicit SPARK_Mode pragma, 11967 -- the latter should be the one applicable to the instance. 11968 11969 if not Ignore_SPARK_Mode_Pragmas_In_Instance 11970 and then SPARK_Mode /= Off 11971 and then Present (SPARK_Pragma (Gen_Body_Id)) 11972 then 11973 Set_SPARK_Mode (Gen_Body_Id); 11974 end if; 11975 11976 Current_Sem_Unit := Body_Info.Current_Sem_Unit; 11977 Create_Instantiation_Source 11978 (Inst_Node, 11979 Gen_Body_Id, 11980 S_Adjustment); 11981 11982 Act_Body := 11983 Copy_Generic_Node 11984 (Original_Node (Gen_Body), Empty, Instantiating => True); 11985 11986 -- Create proper defining name for the body, to correspond to the one 11987 -- in the spec. 11988 11989 Act_Body_Id := 11990 Make_Defining_Identifier (Sloc (Act_Decl_Id), Chars (Act_Decl_Id)); 11991 11992 Set_Comes_From_Source (Act_Body_Id, Comes_From_Source (Act_Decl_Id)); 11993 Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); 11994 11995 Set_Corresponding_Spec (Act_Body, Act_Decl_Id); 11996 Set_Has_Completion (Act_Decl_Id); 11997 Check_Generic_Actuals (Pack_Id, False); 11998 11999 -- Generate a reference to link the visible subprogram instance to 12000 -- the generic body, which for navigation purposes is the only 12001 -- available source for the instance. 12002 12003 Generate_Reference 12004 (Related_Instance (Pack_Id), 12005 Gen_Body_Id, 'b', Set_Ref => False, Force => True); 12006 12007 -- If it is a child unit, make the parent instance (which is an 12008 -- instance of the parent of the generic) visible. The parent 12009 -- instance is the prefix of the name of the generic unit. 12010 12011 if Ekind (Scope (Gen_Unit)) = E_Generic_Package 12012 and then Nkind (Gen_Id) = N_Expanded_Name 12013 then 12014 Par_Ent := Entity (Prefix (Gen_Id)); 12015 Par_Vis := Is_Immediately_Visible (Par_Ent); 12016 Install_Parent (Par_Ent, In_Body => True); 12017 Par_Installed := True; 12018 12019 elsif Is_Child_Unit (Gen_Unit) then 12020 Par_Ent := Scope (Gen_Unit); 12021 Par_Vis := Is_Immediately_Visible (Par_Ent); 12022 Install_Parent (Par_Ent, In_Body => True); 12023 Par_Installed := True; 12024 end if; 12025 12026 -- Subprogram body is placed in the body of wrapper package, 12027 -- whose spec contains the subprogram declaration as well as 12028 -- the renaming declarations for the generic parameters. 12029 12030 Pack_Body := 12031 Make_Package_Body (Loc, 12032 Defining_Unit_Name => New_Copy (Pack_Id), 12033 Declarations => New_List (Act_Body)); 12034 12035 Set_Corresponding_Spec (Pack_Body, Pack_Id); 12036 12037 -- If the instantiation is a library unit, then build resulting 12038 -- compilation unit nodes for the instance. The declaration of 12039 -- the enclosing package is the grandparent of the subprogram 12040 -- declaration. First replace the instantiation node as the unit 12041 -- of the corresponding compilation. 12042 12043 if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then 12044 if Parent (Inst_Node) = Cunit (Main_Unit) then 12045 Set_Unit (Parent (Inst_Node), Inst_Node); 12046 Build_Instance_Compilation_Unit_Nodes 12047 (Inst_Node, Pack_Body, Parent (Parent (Act_Decl))); 12048 Analyze (Inst_Node); 12049 else 12050 Set_Parent (Pack_Body, Parent (Inst_Node)); 12051 Analyze (Pack_Body); 12052 end if; 12053 12054 else 12055 Insert_Before (Inst_Node, Pack_Body); 12056 Mark_Rewrite_Insertion (Pack_Body); 12057 Analyze (Pack_Body); 12058 12059 if Expander_Active then 12060 Freeze_Subprogram_Body (Inst_Node, Gen_Body, Pack_Id); 12061 end if; 12062 end if; 12063 12064 Inherit_Context (Gen_Body, Inst_Node); 12065 12066 Restore_Private_Views (Pack_Id, False); 12067 12068 if Par_Installed then 12069 Remove_Parent (In_Body => True); 12070 12071 -- Restore the previous visibility of the parent 12072 12073 Set_Is_Immediately_Visible (Par_Ent, Par_Vis); 12074 end if; 12075 12076 Restore_Env; 12077 12078 -- Body not found. Error was emitted already. If there were no previous 12079 -- errors, this may be an instance whose scope is a premature instance. 12080 -- In that case we must insure that the (legal) program does raise 12081 -- program error if executed. We generate a subprogram body for this 12082 -- purpose. See DEC ac30vso. 12083 12084 -- Should not reference proprietary DEC tests in comments ??? 12085 12086 elsif Serious_Errors_Detected = 0 12087 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit 12088 then 12089 if Body_Optional then 12090 goto Leave; 12091 12092 elsif Ekind (Act_Decl_Id) = E_Procedure then 12093 Act_Body := 12094 Make_Subprogram_Body (Loc, 12095 Specification => 12096 Make_Procedure_Specification (Loc, 12097 Defining_Unit_Name => 12098 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 12099 Parameter_Specifications => 12100 New_Copy_List 12101 (Parameter_Specifications (Parent (Act_Decl_Id)))), 12102 12103 Declarations => Empty_List, 12104 Handled_Statement_Sequence => 12105 Make_Handled_Sequence_Of_Statements (Loc, 12106 Statements => New_List ( 12107 Make_Raise_Program_Error (Loc, 12108 Reason => PE_Access_Before_Elaboration)))); 12109 12110 else 12111 Ret_Expr := 12112 Make_Raise_Program_Error (Loc, 12113 Reason => PE_Access_Before_Elaboration); 12114 12115 Set_Etype (Ret_Expr, (Etype (Act_Decl_Id))); 12116 Set_Analyzed (Ret_Expr); 12117 12118 Act_Body := 12119 Make_Subprogram_Body (Loc, 12120 Specification => 12121 Make_Function_Specification (Loc, 12122 Defining_Unit_Name => 12123 Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)), 12124 Parameter_Specifications => 12125 New_Copy_List 12126 (Parameter_Specifications (Parent (Act_Decl_Id))), 12127 Result_Definition => 12128 New_Occurrence_Of (Etype (Act_Decl_Id), Loc)), 12129 12130 Declarations => Empty_List, 12131 Handled_Statement_Sequence => 12132 Make_Handled_Sequence_Of_Statements (Loc, 12133 Statements => New_List ( 12134 Make_Simple_Return_Statement (Loc, Ret_Expr)))); 12135 end if; 12136 12137 Pack_Body := 12138 Make_Package_Body (Loc, 12139 Defining_Unit_Name => New_Copy (Pack_Id), 12140 Declarations => New_List (Act_Body)); 12141 12142 Insert_After (Inst_Node, Pack_Body); 12143 Set_Corresponding_Spec (Pack_Body, Pack_Id); 12144 Analyze (Pack_Body); 12145 end if; 12146 12147 <<Leave>> 12148 12149 -- Restore the context that was in effect prior to instantiating the 12150 -- subprogram body. 12151 12152 Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; 12153 Local_Suppress_Stack_Top := Saved_LSST; 12154 Scope_Suppress := Saved_SS; 12155 Style_Check := Saved_SC; 12156 12157 Expander_Mode_Restore; 12158 Restore_Config_Switches (Saved_CS); 12159 Restore_Ghost_Region (Saved_GM, Saved_IGR); 12160 Restore_SPARK_Mode (Saved_SM, Saved_SMP); 12161 Restore_Warnings (Saved_Warn); 12162 end Instantiate_Subprogram_Body; 12163 12164 ---------------------- 12165 -- Instantiate_Type -- 12166 ---------------------- 12167 12168 function Instantiate_Type 12169 (Formal : Node_Id; 12170 Actual : Node_Id; 12171 Analyzed_Formal : Node_Id; 12172 Actual_Decls : List_Id) return List_Id 12173 is 12174 A_Gen_T : constant Entity_Id := 12175 Defining_Identifier (Analyzed_Formal); 12176 Def : constant Node_Id := Formal_Type_Definition (Formal); 12177 Gen_T : constant Entity_Id := Defining_Identifier (Formal); 12178 Act_T : Entity_Id; 12179 Ancestor : Entity_Id := Empty; 12180 Decl_Node : Node_Id; 12181 Decl_Nodes : List_Id; 12182 Loc : Source_Ptr; 12183 Subt : Entity_Id; 12184 12185 procedure Check_Shared_Variable_Control_Aspects; 12186 -- Ada_2020: Verify that shared variable control aspects (RM C.6) 12187 -- that may be specified for a formal type are obeyed by the actual. 12188 12189 procedure Diagnose_Predicated_Actual; 12190 -- There are a number of constructs in which a discrete type with 12191 -- predicates is illegal, e.g. as an index in an array type declaration. 12192 -- If a generic type is used is such a construct in a generic package 12193 -- declaration, it carries the flag No_Predicate_On_Actual. it is part 12194 -- of the generic contract that the actual cannot have predicates. 12195 12196 procedure Validate_Array_Type_Instance; 12197 procedure Validate_Access_Subprogram_Instance; 12198 procedure Validate_Access_Type_Instance; 12199 procedure Validate_Derived_Type_Instance; 12200 procedure Validate_Derived_Interface_Type_Instance; 12201 procedure Validate_Discriminated_Formal_Type; 12202 procedure Validate_Interface_Type_Instance; 12203 procedure Validate_Private_Type_Instance; 12204 procedure Validate_Incomplete_Type_Instance; 12205 -- These procedures perform validation tests for the named case. 12206 -- Validate_Discriminated_Formal_Type is shared by formal private 12207 -- types and Ada 2012 formal incomplete types. 12208 12209 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean; 12210 -- Check that base types are the same and that the subtypes match 12211 -- statically. Used in several of the above. 12212 12213 -------------------------------------------- 12214 -- Check_Shared_Variable_Control_Aspects -- 12215 -------------------------------------------- 12216 12217 -- Ada_2020: Verify that shared variable control aspects (RM C.6) 12218 -- that may be specified for the formal are obeyed by the actual. 12219 12220 procedure Check_Shared_Variable_Control_Aspects is 12221 begin 12222 if Ada_Version >= Ada_2020 then 12223 if Is_Atomic (A_Gen_T) and then not Is_Atomic (Act_T) then 12224 Error_Msg_NE 12225 ("actual for& must be an atomic type", Actual, A_Gen_T); 12226 end if; 12227 12228 if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then 12229 Error_Msg_NE 12230 ("actual for& must be a Volatile type", Actual, A_Gen_T); 12231 end if; 12232 12233 if 12234 Is_Independent (A_Gen_T) and then not Is_Independent (Act_T) 12235 then 12236 Error_Msg_NE 12237 ("actual for& must be an Independent type", Actual, A_Gen_T); 12238 end if; 12239 12240 -- We assume that an array type whose atomic component type 12241 -- is Atomic is equivalent to an array type with the explicit 12242 -- aspect Has_Atomic_Components. This is a reasonable inference 12243 -- from the intent of AI12-0282, and makes it legal to use an 12244 -- actual that does not have the identical aspect as the formal. 12245 12246 if Has_Atomic_Components (A_Gen_T) 12247 and then not Has_Atomic_Components (Act_T) 12248 then 12249 if Is_Array_Type (Act_T) 12250 and then Is_Atomic (Component_Type (Act_T)) 12251 then 12252 null; 12253 12254 else 12255 Error_Msg_NE 12256 ("actual for& must have atomic components", 12257 Actual, A_Gen_T); 12258 end if; 12259 end if; 12260 12261 if Has_Independent_Components (A_Gen_T) 12262 and then not Has_Independent_Components (Act_T) 12263 then 12264 Error_Msg_NE 12265 ("actual for& must have independent components", 12266 Actual, A_Gen_T); 12267 end if; 12268 12269 if Has_Volatile_Components (A_Gen_T) 12270 and then not Has_Volatile_Components (Act_T) 12271 then 12272 if Is_Array_Type (Act_T) 12273 and then Is_Volatile (Component_Type (Act_T)) 12274 then 12275 null; 12276 12277 else 12278 Error_Msg_NE 12279 ("actual for& must have volatile components", 12280 Actual, A_Gen_T); 12281 end if; 12282 end if; 12283 end if; 12284 end Check_Shared_Variable_Control_Aspects; 12285 12286 --------------------------------- 12287 -- Diagnose_Predicated_Actual -- 12288 --------------------------------- 12289 12290 procedure Diagnose_Predicated_Actual is 12291 begin 12292 if No_Predicate_On_Actual (A_Gen_T) 12293 and then Has_Predicates (Act_T) 12294 then 12295 Error_Msg_NE 12296 ("actual for& cannot be a type with predicate", 12297 Instantiation_Node, A_Gen_T); 12298 12299 elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) 12300 and then Has_Predicates (Act_T) 12301 and then not Has_Static_Predicate_Aspect (Act_T) 12302 then 12303 Error_Msg_NE 12304 ("actual for& cannot be a type with a dynamic predicate", 12305 Instantiation_Node, A_Gen_T); 12306 end if; 12307 end Diagnose_Predicated_Actual; 12308 12309 -------------------- 12310 -- Subtypes_Match -- 12311 -------------------- 12312 12313 function Subtypes_Match (Gen_T, Act_T : Entity_Id) return Boolean is 12314 T : constant Entity_Id := Get_Instance_Of (Gen_T); 12315 12316 begin 12317 -- Some detailed comments would be useful here ??? 12318 12319 return ((Base_Type (T) = Act_T 12320 or else Base_Type (T) = Base_Type (Act_T)) 12321 and then Subtypes_Statically_Match (T, Act_T)) 12322 12323 or else (Is_Class_Wide_Type (Gen_T) 12324 and then Is_Class_Wide_Type (Act_T) 12325 and then Subtypes_Match 12326 (Get_Instance_Of (Root_Type (Gen_T)), 12327 Root_Type (Act_T))) 12328 12329 or else 12330 (Ekind_In (Gen_T, E_Anonymous_Access_Subprogram_Type, 12331 E_Anonymous_Access_Type) 12332 and then Ekind (Act_T) = Ekind (Gen_T) 12333 and then Subtypes_Statically_Match 12334 (Designated_Type (Gen_T), Designated_Type (Act_T))); 12335 end Subtypes_Match; 12336 12337 ----------------------------------------- 12338 -- Validate_Access_Subprogram_Instance -- 12339 ----------------------------------------- 12340 12341 procedure Validate_Access_Subprogram_Instance is 12342 begin 12343 if not Is_Access_Type (Act_T) 12344 or else Ekind (Designated_Type (Act_T)) /= E_Subprogram_Type 12345 then 12346 Error_Msg_NE 12347 ("expect access type in instantiation of &", Actual, Gen_T); 12348 Abandon_Instantiation (Actual); 12349 end if; 12350 12351 -- According to AI05-288, actuals for access_to_subprograms must be 12352 -- subtype conformant with the generic formal. Previous to AI05-288 12353 -- only mode conformance was required. 12354 12355 -- This is a binding interpretation that applies to previous versions 12356 -- of the language, no need to maintain previous weaker checks. 12357 12358 Check_Subtype_Conformant 12359 (Designated_Type (Act_T), 12360 Designated_Type (A_Gen_T), 12361 Actual, 12362 Get_Inst => True); 12363 12364 if Ekind (Base_Type (Act_T)) = E_Access_Protected_Subprogram_Type then 12365 if Ekind (A_Gen_T) = E_Access_Subprogram_Type then 12366 Error_Msg_NE 12367 ("protected access type not allowed for formal &", 12368 Actual, Gen_T); 12369 end if; 12370 12371 elsif Ekind (A_Gen_T) = E_Access_Protected_Subprogram_Type then 12372 Error_Msg_NE 12373 ("expect protected access type for formal &", 12374 Actual, Gen_T); 12375 end if; 12376 12377 -- If the formal has a specified convention (which in most cases 12378 -- will be StdCall) verify that the actual has the same convention. 12379 12380 if Has_Convention_Pragma (A_Gen_T) 12381 and then Convention (A_Gen_T) /= Convention (Act_T) 12382 then 12383 Error_Msg_Name_1 := Get_Convention_Name (Convention (A_Gen_T)); 12384 Error_Msg_NE 12385 ("actual for formal & must have convention %", Actual, Gen_T); 12386 end if; 12387 12388 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 12389 Error_Msg_NE 12390 ("non null exclusion of actual and formal & do not match", 12391 Actual, Gen_T); 12392 end if; 12393 end Validate_Access_Subprogram_Instance; 12394 12395 ----------------------------------- 12396 -- Validate_Access_Type_Instance -- 12397 ----------------------------------- 12398 12399 procedure Validate_Access_Type_Instance is 12400 Desig_Type : constant Entity_Id := 12401 Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T); 12402 Desig_Act : Entity_Id; 12403 12404 begin 12405 if not Is_Access_Type (Act_T) then 12406 Error_Msg_NE 12407 ("expect access type in instantiation of &", Actual, Gen_T); 12408 Abandon_Instantiation (Actual); 12409 end if; 12410 12411 if Is_Access_Constant (A_Gen_T) then 12412 if not Is_Access_Constant (Act_T) then 12413 Error_Msg_N 12414 ("actual type must be access-to-constant type", Actual); 12415 Abandon_Instantiation (Actual); 12416 end if; 12417 else 12418 if Is_Access_Constant (Act_T) then 12419 Error_Msg_N 12420 ("actual type must be access-to-variable type", Actual); 12421 Abandon_Instantiation (Actual); 12422 12423 elsif Ekind (A_Gen_T) = E_General_Access_Type 12424 and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type 12425 then 12426 Error_Msg_N -- CODEFIX 12427 ("actual must be general access type!", Actual); 12428 Error_Msg_NE -- CODEFIX 12429 ("add ALL to }!", Actual, Act_T); 12430 Abandon_Instantiation (Actual); 12431 end if; 12432 end if; 12433 12434 -- The designated subtypes, that is to say the subtypes introduced 12435 -- by an access type declaration (and not by a subtype declaration) 12436 -- must match. 12437 12438 Desig_Act := Designated_Type (Base_Type (Act_T)); 12439 12440 -- The designated type may have been introduced through a limited_ 12441 -- with clause, in which case retrieve the non-limited view. This 12442 -- applies to incomplete types as well as to class-wide types. 12443 12444 if From_Limited_With (Desig_Act) then 12445 Desig_Act := Available_View (Desig_Act); 12446 end if; 12447 12448 if not Subtypes_Match (Desig_Type, Desig_Act) then 12449 Error_Msg_NE 12450 ("designated type of actual does not match that of formal &", 12451 Actual, Gen_T); 12452 12453 if not Predicates_Match (Desig_Type, Desig_Act) then 12454 Error_Msg_N ("\predicates do not match", Actual); 12455 end if; 12456 12457 Abandon_Instantiation (Actual); 12458 12459 elsif Is_Access_Type (Designated_Type (Act_T)) 12460 and then Is_Constrained (Designated_Type (Designated_Type (Act_T))) 12461 /= 12462 Is_Constrained (Designated_Type (Desig_Type)) 12463 then 12464 Error_Msg_NE 12465 ("designated type of actual does not match that of formal &", 12466 Actual, Gen_T); 12467 12468 if not Predicates_Match (Desig_Type, Desig_Act) then 12469 Error_Msg_N ("\predicates do not match", Actual); 12470 end if; 12471 12472 Abandon_Instantiation (Actual); 12473 end if; 12474 12475 -- Ada 2005: null-exclusion indicators of the two types must agree 12476 12477 if Can_Never_Be_Null (A_Gen_T) /= Can_Never_Be_Null (Act_T) then 12478 Error_Msg_NE 12479 ("non null exclusion of actual and formal & do not match", 12480 Actual, Gen_T); 12481 end if; 12482 end Validate_Access_Type_Instance; 12483 12484 ---------------------------------- 12485 -- Validate_Array_Type_Instance -- 12486 ---------------------------------- 12487 12488 procedure Validate_Array_Type_Instance is 12489 I1 : Node_Id; 12490 I2 : Node_Id; 12491 T2 : Entity_Id; 12492 12493 function Formal_Dimensions return Nat; 12494 -- Count number of dimensions in array type formal 12495 12496 ----------------------- 12497 -- Formal_Dimensions -- 12498 ----------------------- 12499 12500 function Formal_Dimensions return Nat is 12501 Num : Nat := 0; 12502 Index : Node_Id; 12503 12504 begin 12505 if Nkind (Def) = N_Constrained_Array_Definition then 12506 Index := First (Discrete_Subtype_Definitions (Def)); 12507 else 12508 Index := First (Subtype_Marks (Def)); 12509 end if; 12510 12511 while Present (Index) loop 12512 Num := Num + 1; 12513 Next_Index (Index); 12514 end loop; 12515 12516 return Num; 12517 end Formal_Dimensions; 12518 12519 -- Start of processing for Validate_Array_Type_Instance 12520 12521 begin 12522 if not Is_Array_Type (Act_T) then 12523 Error_Msg_NE 12524 ("expect array type in instantiation of &", Actual, Gen_T); 12525 Abandon_Instantiation (Actual); 12526 12527 elsif Nkind (Def) = N_Constrained_Array_Definition then 12528 if not (Is_Constrained (Act_T)) then 12529 Error_Msg_NE 12530 ("expect constrained array in instantiation of &", 12531 Actual, Gen_T); 12532 Abandon_Instantiation (Actual); 12533 end if; 12534 12535 else 12536 if Is_Constrained (Act_T) then 12537 Error_Msg_NE 12538 ("expect unconstrained array in instantiation of &", 12539 Actual, Gen_T); 12540 Abandon_Instantiation (Actual); 12541 end if; 12542 end if; 12543 12544 if Formal_Dimensions /= Number_Dimensions (Act_T) then 12545 Error_Msg_NE 12546 ("dimensions of actual do not match formal &", Actual, Gen_T); 12547 Abandon_Instantiation (Actual); 12548 end if; 12549 12550 I1 := First_Index (A_Gen_T); 12551 I2 := First_Index (Act_T); 12552 for J in 1 .. Formal_Dimensions loop 12553 12554 -- If the indexes of the actual were given by a subtype_mark, 12555 -- the index was transformed into a range attribute. Retrieve 12556 -- the original type mark for checking. 12557 12558 if Is_Entity_Name (Original_Node (I2)) then 12559 T2 := Entity (Original_Node (I2)); 12560 else 12561 T2 := Etype (I2); 12562 end if; 12563 12564 if not Subtypes_Match 12565 (Find_Actual_Type (Etype (I1), A_Gen_T), T2) 12566 then 12567 Error_Msg_NE 12568 ("index types of actual do not match those of formal &", 12569 Actual, Gen_T); 12570 Abandon_Instantiation (Actual); 12571 end if; 12572 12573 Next_Index (I1); 12574 Next_Index (I2); 12575 end loop; 12576 12577 -- Check matching subtypes. Note that there are complex visibility 12578 -- issues when the generic is a child unit and some aspect of the 12579 -- generic type is declared in a parent unit of the generic. We do 12580 -- the test to handle this special case only after a direct check 12581 -- for static matching has failed. The case where both the component 12582 -- type and the array type are separate formals, and the component 12583 -- type is a private view may also require special checking in 12584 -- Subtypes_Match. Finally, we assume that a child instance where 12585 -- the component type comes from a formal of a parent instance is 12586 -- correct because the generic was correct. A more precise check 12587 -- seems too complex to install??? 12588 12589 if Subtypes_Match 12590 (Component_Type (A_Gen_T), Component_Type (Act_T)) 12591 or else 12592 Subtypes_Match 12593 (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T), 12594 Component_Type (Act_T)) 12595 or else 12596 (not Inside_A_Generic 12597 and then Is_Child_Unit (Scope (Component_Type (A_Gen_T)))) 12598 then 12599 null; 12600 else 12601 Error_Msg_NE 12602 ("component subtype of actual does not match that of formal &", 12603 Actual, Gen_T); 12604 Abandon_Instantiation (Actual); 12605 end if; 12606 12607 if Has_Aliased_Components (A_Gen_T) 12608 and then not Has_Aliased_Components (Act_T) 12609 then 12610 Error_Msg_NE 12611 ("actual must have aliased components to match formal type &", 12612 Actual, Gen_T); 12613 end if; 12614 end Validate_Array_Type_Instance; 12615 12616 ----------------------------------------------- 12617 -- Validate_Derived_Interface_Type_Instance -- 12618 ----------------------------------------------- 12619 12620 procedure Validate_Derived_Interface_Type_Instance is 12621 Par : constant Entity_Id := Entity (Subtype_Indication (Def)); 12622 Elmt : Elmt_Id; 12623 12624 begin 12625 -- First apply interface instance checks 12626 12627 Validate_Interface_Type_Instance; 12628 12629 -- Verify that immediate parent interface is an ancestor of 12630 -- the actual. 12631 12632 if Present (Par) 12633 and then not Interface_Present_In_Ancestor (Act_T, Par) 12634 then 12635 Error_Msg_NE 12636 ("interface actual must include progenitor&", Actual, Par); 12637 end if; 12638 12639 -- Now verify that the actual includes all other ancestors of 12640 -- the formal. 12641 12642 Elmt := First_Elmt (Interfaces (A_Gen_T)); 12643 while Present (Elmt) loop 12644 if not Interface_Present_In_Ancestor 12645 (Act_T, Get_Instance_Of (Node (Elmt))) 12646 then 12647 Error_Msg_NE 12648 ("interface actual must include progenitor&", 12649 Actual, Node (Elmt)); 12650 end if; 12651 12652 Next_Elmt (Elmt); 12653 end loop; 12654 end Validate_Derived_Interface_Type_Instance; 12655 12656 ------------------------------------ 12657 -- Validate_Derived_Type_Instance -- 12658 ------------------------------------ 12659 12660 procedure Validate_Derived_Type_Instance is 12661 Actual_Discr : Entity_Id; 12662 Ancestor_Discr : Entity_Id; 12663 12664 begin 12665 -- Verify that the actual includes the progenitors of the formal, 12666 -- if any. The formal may depend on previous formals and their 12667 -- instance, so we must examine instance of interfaces if present. 12668 -- The actual may be an extension of an interface, in which case 12669 -- it does not appear in the interface list, so this must be 12670 -- checked separately. 12671 12672 if Present (Interface_List (Def)) then 12673 if not Has_Interfaces (Act_T) then 12674 Error_Msg_NE 12675 ("actual must implement all interfaces of formal&", 12676 Actual, A_Gen_T); 12677 12678 else 12679 declare 12680 Act_Iface_List : Elist_Id; 12681 Iface : Node_Id; 12682 Iface_Ent : Entity_Id; 12683 12684 function Instance_Exists (I : Entity_Id) return Boolean; 12685 -- If the interface entity is declared in a generic unit, 12686 -- this can only be legal if we are within an instantiation 12687 -- of a child of that generic. There is currently no 12688 -- mechanism to relate an interface declared within a 12689 -- generic to the corresponding interface in an instance, 12690 -- so we traverse the list of interfaces of the actual, 12691 -- looking for a name match. 12692 12693 --------------------- 12694 -- Instance_Exists -- 12695 --------------------- 12696 12697 function Instance_Exists (I : Entity_Id) return Boolean is 12698 Iface_Elmt : Elmt_Id; 12699 12700 begin 12701 Iface_Elmt := First_Elmt (Act_Iface_List); 12702 while Present (Iface_Elmt) loop 12703 if Is_Generic_Instance (Scope (Node (Iface_Elmt))) 12704 and then Chars (Node (Iface_Elmt)) = Chars (I) 12705 then 12706 return True; 12707 end if; 12708 12709 Next_Elmt (Iface_Elmt); 12710 end loop; 12711 12712 return False; 12713 end Instance_Exists; 12714 12715 begin 12716 Iface := First (Abstract_Interface_List (A_Gen_T)); 12717 Collect_Interfaces (Act_T, Act_Iface_List); 12718 12719 while Present (Iface) loop 12720 Iface_Ent := Get_Instance_Of (Entity (Iface)); 12721 12722 if Is_Ancestor (Iface_Ent, Act_T) 12723 or else Is_Progenitor (Iface_Ent, Act_T) 12724 then 12725 null; 12726 12727 elsif Ekind (Scope (Iface_Ent)) = E_Generic_Package 12728 and then Instance_Exists (Iface_Ent) 12729 then 12730 null; 12731 12732 else 12733 Error_Msg_Name_1 := Chars (Act_T); 12734 Error_Msg_NE 12735 ("Actual% must implement interface&", 12736 Actual, Etype (Iface)); 12737 end if; 12738 12739 Next (Iface); 12740 end loop; 12741 end; 12742 end if; 12743 end if; 12744 12745 -- If the parent type in the generic declaration is itself a previous 12746 -- formal type, then it is local to the generic and absent from the 12747 -- analyzed generic definition. In that case the ancestor is the 12748 -- instance of the formal (which must have been instantiated 12749 -- previously), unless the ancestor is itself a formal derived type. 12750 -- In this latter case (which is the subject of Corrigendum 8652/0038 12751 -- (AI-202) the ancestor of the formals is the ancestor of its 12752 -- parent. Otherwise, the analyzed generic carries the parent type. 12753 -- If the parent type is defined in a previous formal package, then 12754 -- the scope of that formal package is that of the generic type 12755 -- itself, and it has already been mapped into the corresponding type 12756 -- in the actual package. 12757 12758 -- Common case: parent type defined outside of the generic 12759 12760 if Is_Entity_Name (Subtype_Mark (Def)) 12761 and then Present (Entity (Subtype_Mark (Def))) 12762 then 12763 Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def))); 12764 12765 -- Check whether parent is defined in a previous formal package 12766 12767 elsif 12768 Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T) 12769 then 12770 Ancestor := 12771 Get_Instance_Of (Base_Type (Etype (A_Gen_T))); 12772 12773 -- The type may be a local derivation, or a type extension of a 12774 -- previous formal, or of a formal of a parent package. 12775 12776 elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) 12777 or else 12778 Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private 12779 then 12780 -- Check whether the parent is another derived formal type in the 12781 -- same generic unit. 12782 12783 if Etype (A_Gen_T) /= A_Gen_T 12784 and then Is_Generic_Type (Etype (A_Gen_T)) 12785 and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T) 12786 and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T) 12787 then 12788 -- Locate ancestor of parent from the subtype declaration 12789 -- created for the actual. 12790 12791 declare 12792 Decl : Node_Id; 12793 12794 begin 12795 Decl := First (Actual_Decls); 12796 while Present (Decl) loop 12797 if Nkind (Decl) = N_Subtype_Declaration 12798 and then Chars (Defining_Identifier (Decl)) = 12799 Chars (Etype (A_Gen_T)) 12800 then 12801 Ancestor := Generic_Parent_Type (Decl); 12802 exit; 12803 else 12804 Next (Decl); 12805 end if; 12806 end loop; 12807 end; 12808 12809 pragma Assert (Present (Ancestor)); 12810 12811 -- The ancestor itself may be a previous formal that has been 12812 -- instantiated. 12813 12814 Ancestor := Get_Instance_Of (Ancestor); 12815 12816 else 12817 Ancestor := 12818 Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T))); 12819 end if; 12820 12821 -- Check whether parent is a previous formal of the current generic 12822 12823 elsif Is_Derived_Type (A_Gen_T) 12824 and then Is_Generic_Type (Etype (A_Gen_T)) 12825 and then Scope (A_Gen_T) = Scope (Etype (A_Gen_T)) 12826 then 12827 Ancestor := Get_Instance_Of (First_Subtype (Etype (A_Gen_T))); 12828 12829 -- An unusual case: the actual is a type declared in a parent unit, 12830 -- but is not a formal type so there is no instance_of for it. 12831 -- Retrieve it by analyzing the record extension. 12832 12833 elsif Is_Child_Unit (Scope (A_Gen_T)) 12834 and then In_Open_Scopes (Scope (Act_T)) 12835 and then Is_Generic_Instance (Scope (Act_T)) 12836 then 12837 Analyze (Subtype_Mark (Def)); 12838 Ancestor := Entity (Subtype_Mark (Def)); 12839 12840 else 12841 Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T))); 12842 end if; 12843 12844 -- If the formal derived type has pragma Preelaborable_Initialization 12845 -- then the actual type must have preelaborable initialization. 12846 12847 if Known_To_Have_Preelab_Init (A_Gen_T) 12848 and then not Has_Preelaborable_Initialization (Act_T) 12849 then 12850 Error_Msg_NE 12851 ("actual for & must have preelaborable initialization", 12852 Actual, Gen_T); 12853 end if; 12854 12855 -- Ada 2005 (AI-251) 12856 12857 if Ada_Version >= Ada_2005 and then Is_Interface (Ancestor) then 12858 if not Interface_Present_In_Ancestor (Act_T, Ancestor) then 12859 Error_Msg_NE 12860 ("(Ada 2005) expected type implementing & in instantiation", 12861 Actual, Ancestor); 12862 end if; 12863 12864 -- Finally verify that the (instance of) the ancestor is an ancestor 12865 -- of the actual. 12866 12867 elsif not Is_Ancestor (Base_Type (Ancestor), Act_T) then 12868 Error_Msg_NE 12869 ("expect type derived from & in instantiation", 12870 Actual, First_Subtype (Ancestor)); 12871 Abandon_Instantiation (Actual); 12872 end if; 12873 12874 -- Ada 2005 (AI-443): Synchronized formal derived type checks. Note 12875 -- that the formal type declaration has been rewritten as a private 12876 -- extension. 12877 12878 if Ada_Version >= Ada_2005 12879 and then Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration 12880 and then Synchronized_Present (Parent (A_Gen_T)) 12881 then 12882 -- The actual must be a synchronized tagged type 12883 12884 if not Is_Tagged_Type (Act_T) then 12885 Error_Msg_N 12886 ("actual of synchronized type must be tagged", Actual); 12887 Abandon_Instantiation (Actual); 12888 12889 elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration 12890 and then Nkind (Type_Definition (Parent (Act_T))) = 12891 N_Derived_Type_Definition 12892 and then not Synchronized_Present 12893 (Type_Definition (Parent (Act_T))) 12894 then 12895 Error_Msg_N 12896 ("actual of synchronized type must be synchronized", Actual); 12897 Abandon_Instantiation (Actual); 12898 end if; 12899 end if; 12900 12901 -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1 12902 -- removes the second instance of the phrase "or allow pass by copy". 12903 12904 -- In Ada_2020 the aspect may be specified explicitly for the formal 12905 -- regardless of whether an ancestor obeys it. 12906 12907 if Is_Atomic (Act_T) 12908 and then not Is_Atomic (Ancestor) 12909 and then not Is_Atomic (A_Gen_T) 12910 then 12911 Error_Msg_N 12912 ("cannot have atomic actual type for non-atomic formal type", 12913 Actual); 12914 12915 elsif Is_Volatile (Act_T) 12916 and then not Is_Volatile (Ancestor) 12917 and then not Is_Volatile (A_Gen_T) 12918 then 12919 Error_Msg_N 12920 ("cannot have volatile actual type for non-volatile formal type", 12921 Actual); 12922 end if; 12923 12924 -- It should not be necessary to check for unknown discriminants on 12925 -- Formal, but for some reason Has_Unknown_Discriminants is false for 12926 -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This 12927 -- needs fixing. ??? 12928 12929 if Is_Definite_Subtype (A_Gen_T) 12930 and then not Unknown_Discriminants_Present (Formal) 12931 and then not Is_Definite_Subtype (Act_T) 12932 then 12933 Error_Msg_N ("actual subtype must be constrained", Actual); 12934 Abandon_Instantiation (Actual); 12935 end if; 12936 12937 if not Unknown_Discriminants_Present (Formal) then 12938 if Is_Constrained (Ancestor) then 12939 if not Is_Constrained (Act_T) then 12940 Error_Msg_N ("actual subtype must be constrained", Actual); 12941 Abandon_Instantiation (Actual); 12942 end if; 12943 12944 -- Ancestor is unconstrained, Check if generic formal and actual 12945 -- agree on constrainedness. The check only applies to array types 12946 -- and discriminated types. 12947 12948 elsif Is_Constrained (Act_T) then 12949 if Ekind (Ancestor) = E_Access_Type 12950 or else (not Is_Constrained (A_Gen_T) 12951 and then Is_Composite_Type (A_Gen_T)) 12952 then 12953 Error_Msg_N ("actual subtype must be unconstrained", Actual); 12954 Abandon_Instantiation (Actual); 12955 end if; 12956 12957 -- A class-wide type is only allowed if the formal has unknown 12958 -- discriminants. 12959 12960 elsif Is_Class_Wide_Type (Act_T) 12961 and then not Has_Unknown_Discriminants (Ancestor) 12962 then 12963 Error_Msg_NE 12964 ("actual for & cannot be a class-wide type", Actual, Gen_T); 12965 Abandon_Instantiation (Actual); 12966 12967 -- Otherwise, the formal and actual must have the same number 12968 -- of discriminants and each discriminant of the actual must 12969 -- correspond to a discriminant of the formal. 12970 12971 elsif Has_Discriminants (Act_T) 12972 and then not Has_Unknown_Discriminants (Act_T) 12973 and then Has_Discriminants (Ancestor) 12974 then 12975 Actual_Discr := First_Discriminant (Act_T); 12976 Ancestor_Discr := First_Discriminant (Ancestor); 12977 while Present (Actual_Discr) 12978 and then Present (Ancestor_Discr) 12979 loop 12980 if Base_Type (Act_T) /= Base_Type (Ancestor) and then 12981 No (Corresponding_Discriminant (Actual_Discr)) 12982 then 12983 Error_Msg_NE 12984 ("discriminant & does not correspond " 12985 & "to ancestor discriminant", Actual, Actual_Discr); 12986 Abandon_Instantiation (Actual); 12987 end if; 12988 12989 Next_Discriminant (Actual_Discr); 12990 Next_Discriminant (Ancestor_Discr); 12991 end loop; 12992 12993 if Present (Actual_Discr) or else Present (Ancestor_Discr) then 12994 Error_Msg_NE 12995 ("actual for & must have same number of discriminants", 12996 Actual, Gen_T); 12997 Abandon_Instantiation (Actual); 12998 end if; 12999 13000 -- This case should be caught by the earlier check for 13001 -- constrainedness, but the check here is added for completeness. 13002 13003 elsif Has_Discriminants (Act_T) 13004 and then not Has_Unknown_Discriminants (Act_T) 13005 then 13006 Error_Msg_NE 13007 ("actual for & must not have discriminants", Actual, Gen_T); 13008 Abandon_Instantiation (Actual); 13009 13010 elsif Has_Discriminants (Ancestor) then 13011 Error_Msg_NE 13012 ("actual for & must have known discriminants", Actual, Gen_T); 13013 Abandon_Instantiation (Actual); 13014 end if; 13015 13016 if not Subtypes_Statically_Compatible 13017 (Act_T, Ancestor, Formal_Derived_Matching => True) 13018 then 13019 Error_Msg_N 13020 ("constraint on actual is incompatible with formal", Actual); 13021 Abandon_Instantiation (Actual); 13022 end if; 13023 end if; 13024 13025 -- If the formal and actual types are abstract, check that there 13026 -- are no abstract primitives of the actual type that correspond to 13027 -- nonabstract primitives of the formal type (second sentence of 13028 -- RM95 3.9.3(9)). 13029 13030 if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then 13031 Check_Abstract_Primitives : declare 13032 Gen_Prims : constant Elist_Id := 13033 Primitive_Operations (A_Gen_T); 13034 Gen_Elmt : Elmt_Id; 13035 Gen_Subp : Entity_Id; 13036 Anc_Subp : Entity_Id; 13037 Anc_Formal : Entity_Id; 13038 Anc_F_Type : Entity_Id; 13039 13040 Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); 13041 Act_Elmt : Elmt_Id; 13042 Act_Subp : Entity_Id; 13043 Act_Formal : Entity_Id; 13044 Act_F_Type : Entity_Id; 13045 13046 Subprograms_Correspond : Boolean; 13047 13048 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; 13049 -- Returns true if T2 is derived directly or indirectly from 13050 -- T1, including derivations from interfaces. T1 and T2 are 13051 -- required to be specific tagged base types. 13052 13053 ------------------------ 13054 -- Is_Tagged_Ancestor -- 13055 ------------------------ 13056 13057 function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean 13058 is 13059 Intfc_Elmt : Elmt_Id; 13060 13061 begin 13062 -- The predicate is satisfied if the types are the same 13063 13064 if T1 = T2 then 13065 return True; 13066 13067 -- If we've reached the top of the derivation chain then 13068 -- we know that T1 is not an ancestor of T2. 13069 13070 elsif Etype (T2) = T2 then 13071 return False; 13072 13073 -- Proceed to check T2's immediate parent 13074 13075 elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then 13076 return True; 13077 13078 -- Finally, check to see if T1 is an ancestor of any of T2's 13079 -- progenitors. 13080 13081 else 13082 Intfc_Elmt := First_Elmt (Interfaces (T2)); 13083 while Present (Intfc_Elmt) loop 13084 if Is_Ancestor (T1, Node (Intfc_Elmt)) then 13085 return True; 13086 end if; 13087 13088 Next_Elmt (Intfc_Elmt); 13089 end loop; 13090 end if; 13091 13092 return False; 13093 end Is_Tagged_Ancestor; 13094 13095 -- Start of processing for Check_Abstract_Primitives 13096 13097 begin 13098 -- Loop over all of the formal derived type's primitives 13099 13100 Gen_Elmt := First_Elmt (Gen_Prims); 13101 while Present (Gen_Elmt) loop 13102 Gen_Subp := Node (Gen_Elmt); 13103 13104 -- If the primitive of the formal is not abstract, then 13105 -- determine whether there is a corresponding primitive of 13106 -- the actual type that's abstract. 13107 13108 if not Is_Abstract_Subprogram (Gen_Subp) then 13109 Act_Elmt := First_Elmt (Act_Prims); 13110 while Present (Act_Elmt) loop 13111 Act_Subp := Node (Act_Elmt); 13112 13113 -- If we find an abstract primitive of the actual, 13114 -- then we need to test whether it corresponds to the 13115 -- subprogram from which the generic formal primitive 13116 -- is inherited. 13117 13118 if Is_Abstract_Subprogram (Act_Subp) then 13119 Anc_Subp := Alias (Gen_Subp); 13120 13121 -- Test whether we have a corresponding primitive 13122 -- by comparing names, kinds, formal types, and 13123 -- result types. 13124 13125 if Chars (Anc_Subp) = Chars (Act_Subp) 13126 and then Ekind (Anc_Subp) = Ekind (Act_Subp) 13127 then 13128 Anc_Formal := First_Formal (Anc_Subp); 13129 Act_Formal := First_Formal (Act_Subp); 13130 while Present (Anc_Formal) 13131 and then Present (Act_Formal) 13132 loop 13133 Anc_F_Type := Etype (Anc_Formal); 13134 Act_F_Type := Etype (Act_Formal); 13135 13136 if Ekind (Anc_F_Type) = 13137 E_Anonymous_Access_Type 13138 then 13139 Anc_F_Type := Designated_Type (Anc_F_Type); 13140 13141 if Ekind (Act_F_Type) = 13142 E_Anonymous_Access_Type 13143 then 13144 Act_F_Type := 13145 Designated_Type (Act_F_Type); 13146 else 13147 exit; 13148 end if; 13149 13150 elsif 13151 Ekind (Act_F_Type) = E_Anonymous_Access_Type 13152 then 13153 exit; 13154 end if; 13155 13156 Anc_F_Type := Base_Type (Anc_F_Type); 13157 Act_F_Type := Base_Type (Act_F_Type); 13158 13159 -- If the formal is controlling, then the 13160 -- the type of the actual primitive's formal 13161 -- must be derived directly or indirectly 13162 -- from the type of the ancestor primitive's 13163 -- formal. 13164 13165 if Is_Controlling_Formal (Anc_Formal) then 13166 if not Is_Tagged_Ancestor 13167 (Anc_F_Type, Act_F_Type) 13168 then 13169 exit; 13170 end if; 13171 13172 -- Otherwise the types of the formals must 13173 -- be the same. 13174 13175 elsif Anc_F_Type /= Act_F_Type then 13176 exit; 13177 end if; 13178 13179 Next_Entity (Anc_Formal); 13180 Next_Entity (Act_Formal); 13181 end loop; 13182 13183 -- If we traversed through all of the formals 13184 -- then so far the subprograms correspond, so 13185 -- now check that any result types correspond. 13186 13187 if No (Anc_Formal) and then No (Act_Formal) then 13188 Subprograms_Correspond := True; 13189 13190 if Ekind (Act_Subp) = E_Function then 13191 Anc_F_Type := Etype (Anc_Subp); 13192 Act_F_Type := Etype (Act_Subp); 13193 13194 if Ekind (Anc_F_Type) = 13195 E_Anonymous_Access_Type 13196 then 13197 Anc_F_Type := 13198 Designated_Type (Anc_F_Type); 13199 13200 if Ekind (Act_F_Type) = 13201 E_Anonymous_Access_Type 13202 then 13203 Act_F_Type := 13204 Designated_Type (Act_F_Type); 13205 else 13206 Subprograms_Correspond := False; 13207 end if; 13208 13209 elsif 13210 Ekind (Act_F_Type) 13211 = E_Anonymous_Access_Type 13212 then 13213 Subprograms_Correspond := False; 13214 end if; 13215 13216 Anc_F_Type := Base_Type (Anc_F_Type); 13217 Act_F_Type := Base_Type (Act_F_Type); 13218 13219 -- Now either the result types must be 13220 -- the same or, if the result type is 13221 -- controlling, the result type of the 13222 -- actual primitive must descend from the 13223 -- result type of the ancestor primitive. 13224 13225 if Subprograms_Correspond 13226 and then Anc_F_Type /= Act_F_Type 13227 and then 13228 Has_Controlling_Result (Anc_Subp) 13229 and then not Is_Tagged_Ancestor 13230 (Anc_F_Type, Act_F_Type) 13231 then 13232 Subprograms_Correspond := False; 13233 end if; 13234 end if; 13235 13236 -- Found a matching subprogram belonging to 13237 -- formal ancestor type, so actual subprogram 13238 -- corresponds and this violates 3.9.3(9). 13239 13240 if Subprograms_Correspond then 13241 Error_Msg_NE 13242 ("abstract subprogram & overrides " 13243 & "nonabstract subprogram of ancestor", 13244 Actual, Act_Subp); 13245 end if; 13246 end if; 13247 end if; 13248 end if; 13249 13250 Next_Elmt (Act_Elmt); 13251 end loop; 13252 end if; 13253 13254 Next_Elmt (Gen_Elmt); 13255 end loop; 13256 end Check_Abstract_Primitives; 13257 end if; 13258 13259 -- Verify that limitedness matches. If parent is a limited 13260 -- interface then the generic formal is not unless declared 13261 -- explicitly so. If not declared limited, the actual cannot be 13262 -- limited (see AI05-0087). 13263 13264 -- Even though this AI is a binding interpretation, we enable the 13265 -- check only in Ada 2012 mode, because this improper construct 13266 -- shows up in user code and in existing B-tests. 13267 13268 if Is_Limited_Type (Act_T) 13269 and then not Is_Limited_Type (A_Gen_T) 13270 and then Ada_Version >= Ada_2012 13271 then 13272 if In_Instance then 13273 null; 13274 else 13275 Error_Msg_NE 13276 ("actual for non-limited & cannot be a limited type", 13277 Actual, Gen_T); 13278 Explain_Limited_Type (Act_T, Actual); 13279 Abandon_Instantiation (Actual); 13280 end if; 13281 end if; 13282 13283 -- Don't check Ada_Version here (for now) because AI12-0036 is 13284 -- a binding interpretation; this decision may be reversed if 13285 -- the situation turns out to be similar to that of the preceding 13286 -- Is_Limited_Type test (see preceding comment). 13287 13288 declare 13289 Formal_Is_Private_Extension : constant Boolean := 13290 Nkind (Parent (A_Gen_T)) = N_Private_Extension_Declaration; 13291 13292 Actual_Is_Tagged : constant Boolean := Is_Tagged_Type (Act_T); 13293 begin 13294 if Actual_Is_Tagged /= Formal_Is_Private_Extension then 13295 if In_Instance then 13296 null; 13297 else 13298 if Actual_Is_Tagged then 13299 Error_Msg_NE 13300 ("actual for & cannot be a tagged type", 13301 Actual, Gen_T); 13302 else 13303 Error_Msg_NE 13304 ("actual for & must be a tagged type", 13305 Actual, Gen_T); 13306 end if; 13307 Abandon_Instantiation (Actual); 13308 end if; 13309 end if; 13310 end; 13311 end Validate_Derived_Type_Instance; 13312 13313 ---------------------------------------- 13314 -- Validate_Discriminated_Formal_Type -- 13315 ---------------------------------------- 13316 13317 procedure Validate_Discriminated_Formal_Type is 13318 Formal_Discr : Entity_Id; 13319 Actual_Discr : Entity_Id; 13320 Formal_Subt : Entity_Id; 13321 13322 begin 13323 if Has_Discriminants (A_Gen_T) then 13324 if not Has_Discriminants (Act_T) then 13325 Error_Msg_NE 13326 ("actual for & must have discriminants", Actual, Gen_T); 13327 Abandon_Instantiation (Actual); 13328 13329 elsif Is_Constrained (Act_T) then 13330 Error_Msg_NE 13331 ("actual for & must be unconstrained", Actual, Gen_T); 13332 Abandon_Instantiation (Actual); 13333 13334 else 13335 Formal_Discr := First_Discriminant (A_Gen_T); 13336 Actual_Discr := First_Discriminant (Act_T); 13337 while Formal_Discr /= Empty loop 13338 if Actual_Discr = Empty then 13339 Error_Msg_NE 13340 ("discriminants on actual do not match formal", 13341 Actual, Gen_T); 13342 Abandon_Instantiation (Actual); 13343 end if; 13344 13345 Formal_Subt := Get_Instance_Of (Etype (Formal_Discr)); 13346 13347 -- Access discriminants match if designated types do 13348 13349 if Ekind (Base_Type (Formal_Subt)) = E_Anonymous_Access_Type 13350 and then (Ekind (Base_Type (Etype (Actual_Discr)))) = 13351 E_Anonymous_Access_Type 13352 and then 13353 Get_Instance_Of 13354 (Designated_Type (Base_Type (Formal_Subt))) = 13355 Designated_Type (Base_Type (Etype (Actual_Discr))) 13356 then 13357 null; 13358 13359 elsif Base_Type (Formal_Subt) /= 13360 Base_Type (Etype (Actual_Discr)) 13361 then 13362 Error_Msg_NE 13363 ("types of actual discriminants must match formal", 13364 Actual, Gen_T); 13365 Abandon_Instantiation (Actual); 13366 13367 elsif not Subtypes_Statically_Match 13368 (Formal_Subt, Etype (Actual_Discr)) 13369 and then Ada_Version >= Ada_95 13370 then 13371 Error_Msg_NE 13372 ("subtypes of actual discriminants must match formal", 13373 Actual, Gen_T); 13374 Abandon_Instantiation (Actual); 13375 end if; 13376 13377 Next_Discriminant (Formal_Discr); 13378 Next_Discriminant (Actual_Discr); 13379 end loop; 13380 13381 if Actual_Discr /= Empty then 13382 Error_Msg_NE 13383 ("discriminants on actual do not match formal", 13384 Actual, Gen_T); 13385 Abandon_Instantiation (Actual); 13386 end if; 13387 end if; 13388 end if; 13389 end Validate_Discriminated_Formal_Type; 13390 13391 --------------------------------------- 13392 -- Validate_Incomplete_Type_Instance -- 13393 --------------------------------------- 13394 13395 procedure Validate_Incomplete_Type_Instance is 13396 begin 13397 if not Is_Tagged_Type (Act_T) 13398 and then Is_Tagged_Type (A_Gen_T) 13399 then 13400 Error_Msg_NE 13401 ("actual for & must be a tagged type", Actual, Gen_T); 13402 end if; 13403 13404 Validate_Discriminated_Formal_Type; 13405 end Validate_Incomplete_Type_Instance; 13406 13407 -------------------------------------- 13408 -- Validate_Interface_Type_Instance -- 13409 -------------------------------------- 13410 13411 procedure Validate_Interface_Type_Instance is 13412 begin 13413 if not Is_Interface (Act_T) then 13414 Error_Msg_NE 13415 ("actual for formal interface type must be an interface", 13416 Actual, Gen_T); 13417 13418 elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T) 13419 or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T) 13420 or else Is_Protected_Interface (A_Gen_T) /= 13421 Is_Protected_Interface (Act_T) 13422 or else Is_Synchronized_Interface (A_Gen_T) /= 13423 Is_Synchronized_Interface (Act_T) 13424 then 13425 Error_Msg_NE 13426 ("actual for interface& does not match (RM 12.5.5(4))", 13427 Actual, Gen_T); 13428 end if; 13429 end Validate_Interface_Type_Instance; 13430 13431 ------------------------------------ 13432 -- Validate_Private_Type_Instance -- 13433 ------------------------------------ 13434 13435 procedure Validate_Private_Type_Instance is 13436 begin 13437 if Is_Limited_Type (Act_T) 13438 and then not Is_Limited_Type (A_Gen_T) 13439 then 13440 if In_Instance then 13441 null; 13442 else 13443 Error_Msg_NE 13444 ("actual for non-limited & cannot be a limited type", Actual, 13445 Gen_T); 13446 Explain_Limited_Type (Act_T, Actual); 13447 Abandon_Instantiation (Actual); 13448 end if; 13449 13450 elsif Known_To_Have_Preelab_Init (A_Gen_T) 13451 and then not Has_Preelaborable_Initialization (Act_T) 13452 then 13453 Error_Msg_NE 13454 ("actual for & must have preelaborable initialization", Actual, 13455 Gen_T); 13456 13457 elsif not Is_Definite_Subtype (Act_T) 13458 and then Is_Definite_Subtype (A_Gen_T) 13459 and then Ada_Version >= Ada_95 13460 then 13461 Error_Msg_NE 13462 ("actual for & must be a definite subtype", Actual, Gen_T); 13463 13464 elsif not Is_Tagged_Type (Act_T) 13465 and then Is_Tagged_Type (A_Gen_T) 13466 then 13467 Error_Msg_NE 13468 ("actual for & must be a tagged type", Actual, Gen_T); 13469 end if; 13470 13471 Validate_Discriminated_Formal_Type; 13472 Ancestor := Gen_T; 13473 end Validate_Private_Type_Instance; 13474 13475 -- Start of processing for Instantiate_Type 13476 13477 begin 13478 if Get_Instance_Of (A_Gen_T) /= A_Gen_T then 13479 Error_Msg_N ("duplicate instantiation of generic type", Actual); 13480 return New_List (Error); 13481 13482 elsif not Is_Entity_Name (Actual) 13483 or else not Is_Type (Entity (Actual)) 13484 then 13485 Error_Msg_NE 13486 ("expect valid subtype mark to instantiate &", Actual, Gen_T); 13487 Abandon_Instantiation (Actual); 13488 13489 else 13490 Act_T := Entity (Actual); 13491 13492 -- Ada 2005 (AI-216): An Unchecked_Union subtype shall only be passed 13493 -- as a generic actual parameter if the corresponding formal type 13494 -- does not have a known_discriminant_part, or is a formal derived 13495 -- type that is an Unchecked_Union type. 13496 13497 if Is_Unchecked_Union (Base_Type (Act_T)) then 13498 if not Has_Discriminants (A_Gen_T) 13499 or else (Is_Derived_Type (A_Gen_T) 13500 and then Is_Unchecked_Union (A_Gen_T)) 13501 then 13502 null; 13503 else 13504 Error_Msg_N ("unchecked union cannot be the actual for a " 13505 & "discriminated formal type", Act_T); 13506 13507 end if; 13508 end if; 13509 13510 -- Deal with fixed/floating restrictions 13511 13512 if Is_Floating_Point_Type (Act_T) then 13513 Check_Restriction (No_Floating_Point, Actual); 13514 elsif Is_Fixed_Point_Type (Act_T) then 13515 Check_Restriction (No_Fixed_Point, Actual); 13516 end if; 13517 13518 -- Deal with error of using incomplete type as generic actual. 13519 -- This includes limited views of a type, even if the non-limited 13520 -- view may be available. 13521 13522 if Ekind (Act_T) = E_Incomplete_Type 13523 or else (Is_Class_Wide_Type (Act_T) 13524 and then Ekind (Root_Type (Act_T)) = E_Incomplete_Type) 13525 then 13526 -- If the formal is an incomplete type, the actual can be 13527 -- incomplete as well. 13528 13529 if Ekind (A_Gen_T) = E_Incomplete_Type then 13530 null; 13531 13532 elsif Is_Class_Wide_Type (Act_T) 13533 or else No (Full_View (Act_T)) 13534 then 13535 Error_Msg_N ("premature use of incomplete type", Actual); 13536 Abandon_Instantiation (Actual); 13537 else 13538 Act_T := Full_View (Act_T); 13539 Set_Entity (Actual, Act_T); 13540 13541 if Has_Private_Component (Act_T) then 13542 Error_Msg_N 13543 ("premature use of type with private component", Actual); 13544 end if; 13545 end if; 13546 13547 -- Deal with error of premature use of private type as generic actual 13548 13549 elsif Is_Private_Type (Act_T) 13550 and then Is_Private_Type (Base_Type (Act_T)) 13551 and then not Is_Generic_Type (Act_T) 13552 and then not Is_Derived_Type (Act_T) 13553 and then No (Full_View (Root_Type (Act_T))) 13554 then 13555 -- If the formal is an incomplete type, the actual can be 13556 -- private or incomplete as well. 13557 13558 if Ekind (A_Gen_T) = E_Incomplete_Type then 13559 null; 13560 else 13561 Error_Msg_N ("premature use of private type", Actual); 13562 end if; 13563 13564 elsif Has_Private_Component (Act_T) then 13565 Error_Msg_N 13566 ("premature use of type with private component", Actual); 13567 end if; 13568 13569 Set_Instance_Of (A_Gen_T, Act_T); 13570 13571 -- If the type is generic, the class-wide type may also be used 13572 13573 if Is_Tagged_Type (A_Gen_T) 13574 and then Is_Tagged_Type (Act_T) 13575 and then not Is_Class_Wide_Type (A_Gen_T) 13576 then 13577 Set_Instance_Of (Class_Wide_Type (A_Gen_T), 13578 Class_Wide_Type (Act_T)); 13579 end if; 13580 13581 if not Is_Abstract_Type (A_Gen_T) 13582 and then Is_Abstract_Type (Act_T) 13583 then 13584 Error_Msg_N 13585 ("actual of non-abstract formal cannot be abstract", Actual); 13586 end if; 13587 13588 -- A generic scalar type is a first subtype for which we generate 13589 -- an anonymous base type. Indicate that the instance of this base 13590 -- is the base type of the actual. 13591 13592 if Is_Scalar_Type (A_Gen_T) then 13593 Set_Instance_Of (Etype (A_Gen_T), Etype (Act_T)); 13594 end if; 13595 end if; 13596 13597 Check_Shared_Variable_Control_Aspects; 13598 13599 if Error_Posted (Act_T) then 13600 null; 13601 else 13602 case Nkind (Def) is 13603 when N_Formal_Private_Type_Definition => 13604 Validate_Private_Type_Instance; 13605 13606 when N_Formal_Incomplete_Type_Definition => 13607 Validate_Incomplete_Type_Instance; 13608 13609 when N_Formal_Derived_Type_Definition => 13610 Validate_Derived_Type_Instance; 13611 13612 when N_Formal_Discrete_Type_Definition => 13613 if not Is_Discrete_Type (Act_T) then 13614 Error_Msg_NE 13615 ("expect discrete type in instantiation of&", 13616 Actual, Gen_T); 13617 Abandon_Instantiation (Actual); 13618 end if; 13619 13620 Diagnose_Predicated_Actual; 13621 13622 when N_Formal_Signed_Integer_Type_Definition => 13623 if not Is_Signed_Integer_Type (Act_T) then 13624 Error_Msg_NE 13625 ("expect signed integer type in instantiation of&", 13626 Actual, Gen_T); 13627 Abandon_Instantiation (Actual); 13628 end if; 13629 13630 Diagnose_Predicated_Actual; 13631 13632 when N_Formal_Modular_Type_Definition => 13633 if not Is_Modular_Integer_Type (Act_T) then 13634 Error_Msg_NE 13635 ("expect modular type in instantiation of &", 13636 Actual, Gen_T); 13637 Abandon_Instantiation (Actual); 13638 end if; 13639 13640 Diagnose_Predicated_Actual; 13641 13642 when N_Formal_Floating_Point_Definition => 13643 if not Is_Floating_Point_Type (Act_T) then 13644 Error_Msg_NE 13645 ("expect float type in instantiation of &", Actual, Gen_T); 13646 Abandon_Instantiation (Actual); 13647 end if; 13648 13649 when N_Formal_Ordinary_Fixed_Point_Definition => 13650 if not Is_Ordinary_Fixed_Point_Type (Act_T) then 13651 Error_Msg_NE 13652 ("expect ordinary fixed point type in instantiation of &", 13653 Actual, Gen_T); 13654 Abandon_Instantiation (Actual); 13655 end if; 13656 13657 when N_Formal_Decimal_Fixed_Point_Definition => 13658 if not Is_Decimal_Fixed_Point_Type (Act_T) then 13659 Error_Msg_NE 13660 ("expect decimal type in instantiation of &", 13661 Actual, Gen_T); 13662 Abandon_Instantiation (Actual); 13663 end if; 13664 13665 when N_Array_Type_Definition => 13666 Validate_Array_Type_Instance; 13667 13668 when N_Access_To_Object_Definition => 13669 Validate_Access_Type_Instance; 13670 13671 when N_Access_Function_Definition 13672 | N_Access_Procedure_Definition 13673 => 13674 Validate_Access_Subprogram_Instance; 13675 13676 when N_Record_Definition => 13677 Validate_Interface_Type_Instance; 13678 13679 when N_Derived_Type_Definition => 13680 Validate_Derived_Interface_Type_Instance; 13681 13682 when others => 13683 raise Program_Error; 13684 end case; 13685 end if; 13686 13687 Subt := New_Copy (Gen_T); 13688 13689 -- Use adjusted sloc of subtype name as the location for other nodes in 13690 -- the subtype declaration. 13691 13692 Loc := Sloc (Subt); 13693 13694 Decl_Node := 13695 Make_Subtype_Declaration (Loc, 13696 Defining_Identifier => Subt, 13697 Subtype_Indication => New_Occurrence_Of (Act_T, Loc)); 13698 13699 if Is_Private_Type (Act_T) then 13700 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13701 13702 elsif Is_Access_Type (Act_T) 13703 and then Is_Private_Type (Designated_Type (Act_T)) 13704 then 13705 Set_Has_Private_View (Subtype_Indication (Decl_Node)); 13706 end if; 13707 13708 -- In Ada 2012 the actual may be a limited view. Indicate that 13709 -- the local subtype must be treated as such. 13710 13711 if From_Limited_With (Act_T) then 13712 Set_Ekind (Subt, E_Incomplete_Subtype); 13713 Set_From_Limited_With (Subt); 13714 end if; 13715 13716 Decl_Nodes := New_List (Decl_Node); 13717 13718 -- Flag actual derived types so their elaboration produces the 13719 -- appropriate renamings for the primitive operations of the ancestor. 13720 -- Flag actual for formal private types as well, to determine whether 13721 -- operations in the private part may override inherited operations. 13722 -- If the formal has an interface list, the ancestor is not the 13723 -- parent, but the analyzed formal that includes the interface 13724 -- operations of all its progenitors. 13725 13726 -- Same treatment for formal private types, so we can check whether the 13727 -- type is tagged limited when validating derivations in the private 13728 -- part. (See AI05-096). 13729 13730 if Nkind (Def) = N_Formal_Derived_Type_Definition then 13731 if Present (Interface_List (Def)) then 13732 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13733 else 13734 Set_Generic_Parent_Type (Decl_Node, Ancestor); 13735 end if; 13736 13737 elsif Nkind_In (Def, N_Formal_Private_Type_Definition, 13738 N_Formal_Incomplete_Type_Definition) 13739 then 13740 Set_Generic_Parent_Type (Decl_Node, A_Gen_T); 13741 end if; 13742 13743 -- If the actual is a synchronized type that implements an interface, 13744 -- the primitive operations are attached to the corresponding record, 13745 -- and we have to treat it as an additional generic actual, so that its 13746 -- primitive operations become visible in the instance. The task or 13747 -- protected type itself does not carry primitive operations. 13748 13749 if Is_Concurrent_Type (Act_T) 13750 and then Is_Tagged_Type (Act_T) 13751 and then Present (Corresponding_Record_Type (Act_T)) 13752 and then Present (Ancestor) 13753 and then Is_Interface (Ancestor) 13754 then 13755 declare 13756 Corr_Rec : constant Entity_Id := 13757 Corresponding_Record_Type (Act_T); 13758 New_Corr : Entity_Id; 13759 Corr_Decl : Node_Id; 13760 13761 begin 13762 New_Corr := Make_Temporary (Loc, 'S'); 13763 Corr_Decl := 13764 Make_Subtype_Declaration (Loc, 13765 Defining_Identifier => New_Corr, 13766 Subtype_Indication => 13767 New_Occurrence_Of (Corr_Rec, Loc)); 13768 Append_To (Decl_Nodes, Corr_Decl); 13769 13770 if Ekind (Act_T) = E_Task_Type then 13771 Set_Ekind (Subt, E_Task_Subtype); 13772 else 13773 Set_Ekind (Subt, E_Protected_Subtype); 13774 end if; 13775 13776 Set_Corresponding_Record_Type (Subt, Corr_Rec); 13777 Set_Generic_Parent_Type (Corr_Decl, Ancestor); 13778 Set_Generic_Parent_Type (Decl_Node, Empty); 13779 end; 13780 end if; 13781 13782 -- For a floating-point type, capture dimension info if any, because 13783 -- the generated subtype declaration does not come from source and 13784 -- will not process dimensions. 13785 13786 if Is_Floating_Point_Type (Act_T) then 13787 Copy_Dimensions (Act_T, Subt); 13788 end if; 13789 13790 return Decl_Nodes; 13791 end Instantiate_Type; 13792 13793 --------------------- 13794 -- Is_In_Main_Unit -- 13795 --------------------- 13796 13797 function Is_In_Main_Unit (N : Node_Id) return Boolean is 13798 Unum : constant Unit_Number_Type := Get_Source_Unit (N); 13799 Current_Unit : Node_Id; 13800 13801 begin 13802 if Unum = Main_Unit then 13803 return True; 13804 13805 -- If the current unit is a subunit then it is either the main unit or 13806 -- is being compiled as part of the main unit. 13807 13808 elsif Nkind (N) = N_Compilation_Unit then 13809 return Nkind (Unit (N)) = N_Subunit; 13810 end if; 13811 13812 Current_Unit := Parent (N); 13813 while Present (Current_Unit) 13814 and then Nkind (Current_Unit) /= N_Compilation_Unit 13815 loop 13816 Current_Unit := Parent (Current_Unit); 13817 end loop; 13818 13819 -- The instantiation node is in the main unit, or else the current node 13820 -- (perhaps as the result of nested instantiations) is in the main unit, 13821 -- or in the declaration of the main unit, which in this last case must 13822 -- be a body. 13823 13824 return 13825 Current_Unit = Cunit (Main_Unit) 13826 or else Current_Unit = Library_Unit (Cunit (Main_Unit)) 13827 or else (Present (Current_Unit) 13828 and then Present (Library_Unit (Current_Unit)) 13829 and then Is_In_Main_Unit (Library_Unit (Current_Unit))); 13830 end Is_In_Main_Unit; 13831 13832 ---------------------------- 13833 -- Load_Parent_Of_Generic -- 13834 ---------------------------- 13835 13836 procedure Load_Parent_Of_Generic 13837 (N : Node_Id; 13838 Spec : Node_Id; 13839 Body_Optional : Boolean := False) 13840 is 13841 Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); 13842 Saved_Style_Check : constant Boolean := Style_Check; 13843 Saved_Warnings : constant Warning_Record := Save_Warnings; 13844 True_Parent : Node_Id; 13845 Inst_Node : Node_Id; 13846 OK : Boolean; 13847 Previous_Instances : constant Elist_Id := New_Elmt_List; 13848 13849 procedure Collect_Previous_Instances (Decls : List_Id); 13850 -- Collect all instantiations in the given list of declarations, that 13851 -- precede the generic that we need to load. If the bodies of these 13852 -- instantiations are available, we must analyze them, to ensure that 13853 -- the public symbols generated are the same when the unit is compiled 13854 -- to generate code, and when it is compiled in the context of a unit 13855 -- that needs a particular nested instance. This process is applied to 13856 -- both package and subprogram instances. 13857 13858 -------------------------------- 13859 -- Collect_Previous_Instances -- 13860 -------------------------------- 13861 13862 procedure Collect_Previous_Instances (Decls : List_Id) is 13863 Decl : Node_Id; 13864 13865 begin 13866 Decl := First (Decls); 13867 while Present (Decl) loop 13868 if Sloc (Decl) >= Sloc (Inst_Node) then 13869 return; 13870 13871 -- If Decl is an instantiation, then record it as requiring 13872 -- instantiation of the corresponding body, except if it is an 13873 -- abbreviated instantiation generated internally for conformance 13874 -- checking purposes only for the case of a formal package 13875 -- declared without a box (see Instantiate_Formal_Package). Such 13876 -- an instantiation does not generate any code (the actual code 13877 -- comes from actual) and thus does not need to be analyzed here. 13878 -- If the instantiation appears with a generic package body it is 13879 -- not analyzed here either. 13880 13881 elsif Nkind (Decl) = N_Package_Instantiation 13882 and then not Is_Internal (Defining_Entity (Decl)) 13883 then 13884 Append_Elmt (Decl, Previous_Instances); 13885 13886 -- For a subprogram instantiation, omit instantiations intrinsic 13887 -- operations (Unchecked_Conversions, etc.) that have no bodies. 13888 13889 elsif Nkind_In (Decl, N_Function_Instantiation, 13890 N_Procedure_Instantiation) 13891 and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) 13892 then 13893 Append_Elmt (Decl, Previous_Instances); 13894 13895 elsif Nkind (Decl) = N_Package_Declaration then 13896 Collect_Previous_Instances 13897 (Visible_Declarations (Specification (Decl))); 13898 Collect_Previous_Instances 13899 (Private_Declarations (Specification (Decl))); 13900 13901 -- Previous non-generic bodies may contain instances as well 13902 13903 elsif Nkind (Decl) = N_Package_Body 13904 and then Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package 13905 then 13906 Collect_Previous_Instances (Declarations (Decl)); 13907 13908 elsif Nkind (Decl) = N_Subprogram_Body 13909 and then not Acts_As_Spec (Decl) 13910 and then not Is_Generic_Subprogram (Corresponding_Spec (Decl)) 13911 then 13912 Collect_Previous_Instances (Declarations (Decl)); 13913 end if; 13914 13915 Next (Decl); 13916 end loop; 13917 end Collect_Previous_Instances; 13918 13919 -- Start of processing for Load_Parent_Of_Generic 13920 13921 begin 13922 if not In_Same_Source_Unit (N, Spec) 13923 or else Nkind (Unit (Comp_Unit)) = N_Package_Declaration 13924 or else (Nkind (Unit (Comp_Unit)) = N_Package_Body 13925 and then not Is_In_Main_Unit (Spec)) 13926 then 13927 -- Find body of parent of spec, and analyze it. A special case arises 13928 -- when the parent is an instantiation, that is to say when we are 13929 -- currently instantiating a nested generic. In that case, there is 13930 -- no separate file for the body of the enclosing instance. Instead, 13931 -- the enclosing body must be instantiated as if it were a pending 13932 -- instantiation, in order to produce the body for the nested generic 13933 -- we require now. Note that in that case the generic may be defined 13934 -- in a package body, the instance defined in the same package body, 13935 -- and the original enclosing body may not be in the main unit. 13936 13937 Inst_Node := Empty; 13938 13939 True_Parent := Parent (Spec); 13940 while Present (True_Parent) 13941 and then Nkind (True_Parent) /= N_Compilation_Unit 13942 loop 13943 if Nkind (True_Parent) = N_Package_Declaration 13944 and then 13945 Nkind (Original_Node (True_Parent)) = N_Package_Instantiation 13946 then 13947 -- Parent is a compilation unit that is an instantiation, and 13948 -- instantiation node has been replaced with package decl. 13949 13950 Inst_Node := Original_Node (True_Parent); 13951 exit; 13952 13953 elsif Nkind (True_Parent) = N_Package_Declaration 13954 and then Nkind (Parent (True_Parent)) = N_Compilation_Unit 13955 and then 13956 Nkind (Unit (Parent (True_Parent))) = N_Package_Instantiation 13957 then 13958 -- Parent is a compilation unit that is an instantiation, but 13959 -- instantiation node has not been replaced with package decl. 13960 13961 Inst_Node := Unit (Parent (True_Parent)); 13962 exit; 13963 13964 elsif Nkind (True_Parent) = N_Package_Declaration 13965 and then Nkind (Parent (True_Parent)) /= N_Compilation_Unit 13966 and then Present (Generic_Parent (Specification (True_Parent))) 13967 then 13968 -- Parent is an instantiation within another specification. 13969 -- Declaration for instance has been inserted before original 13970 -- instantiation node. A direct link would be preferable? 13971 13972 Inst_Node := Next (True_Parent); 13973 while Present (Inst_Node) 13974 and then Nkind (Inst_Node) /= N_Package_Instantiation 13975 loop 13976 Next (Inst_Node); 13977 end loop; 13978 13979 -- If the instance appears within a generic, and the generic 13980 -- unit is defined within a formal package of the enclosing 13981 -- generic, there is no generic body available, and none 13982 -- needed. A more precise test should be used ??? 13983 13984 if No (Inst_Node) then 13985 return; 13986 end if; 13987 13988 exit; 13989 13990 else 13991 True_Parent := Parent (True_Parent); 13992 end if; 13993 end loop; 13994 13995 -- Case where we are currently instantiating a nested generic 13996 13997 if Present (Inst_Node) then 13998 if Nkind (Parent (True_Parent)) = N_Compilation_Unit then 13999 14000 -- Instantiation node and declaration of instantiated package 14001 -- were exchanged when only the declaration was needed. 14002 -- Restore instantiation node before proceeding with body. 14003 14004 Set_Unit (Parent (True_Parent), Inst_Node); 14005 end if; 14006 14007 -- Now complete instantiation of enclosing body, if it appears in 14008 -- some other unit. If it appears in the current unit, the body 14009 -- will have been instantiated already. 14010 14011 if No (Corresponding_Body (Instance_Spec (Inst_Node))) then 14012 14013 -- We need to determine the expander mode to instantiate the 14014 -- enclosing body. Because the generic body we need may use 14015 -- global entities declared in the enclosing package (including 14016 -- aggregates) it is in general necessary to compile this body 14017 -- with expansion enabled, except if we are within a generic 14018 -- package, in which case the usual generic rule applies. 14019 14020 declare 14021 Exp_Status : Boolean := True; 14022 Scop : Entity_Id; 14023 14024 begin 14025 -- Loop through scopes looking for generic package 14026 14027 Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node))); 14028 while Present (Scop) 14029 and then Scop /= Standard_Standard 14030 loop 14031 if Ekind (Scop) = E_Generic_Package then 14032 Exp_Status := False; 14033 exit; 14034 end if; 14035 14036 Scop := Scope (Scop); 14037 end loop; 14038 14039 -- Collect previous instantiations in the unit that contains 14040 -- the desired generic. 14041 14042 if Nkind (Parent (True_Parent)) /= N_Compilation_Unit 14043 and then not Body_Optional 14044 then 14045 declare 14046 Decl : Elmt_Id; 14047 Info : Pending_Body_Info; 14048 Par : Node_Id; 14049 14050 begin 14051 Par := Parent (Inst_Node); 14052 while Present (Par) loop 14053 exit when Nkind (Parent (Par)) = N_Compilation_Unit; 14054 Par := Parent (Par); 14055 end loop; 14056 14057 pragma Assert (Present (Par)); 14058 14059 if Nkind (Par) = N_Package_Body then 14060 Collect_Previous_Instances (Declarations (Par)); 14061 14062 elsif Nkind (Par) = N_Package_Declaration then 14063 Collect_Previous_Instances 14064 (Visible_Declarations (Specification (Par))); 14065 Collect_Previous_Instances 14066 (Private_Declarations (Specification (Par))); 14067 14068 else 14069 -- Enclosing unit is a subprogram body. In this 14070 -- case all instance bodies are processed in order 14071 -- and there is no need to collect them separately. 14072 14073 null; 14074 end if; 14075 14076 Decl := First_Elmt (Previous_Instances); 14077 while Present (Decl) loop 14078 Info := 14079 (Act_Decl => 14080 Instance_Spec (Node (Decl)), 14081 Config_Switches => Save_Config_Switches, 14082 Current_Sem_Unit => 14083 Get_Code_Unit (Sloc (Node (Decl))), 14084 Expander_Status => Exp_Status, 14085 Inst_Node => Node (Decl), 14086 Local_Suppress_Stack_Top => 14087 Local_Suppress_Stack_Top, 14088 Scope_Suppress => Scope_Suppress, 14089 Warnings => Save_Warnings); 14090 14091 -- Package instance 14092 14093 if Nkind (Node (Decl)) = N_Package_Instantiation 14094 then 14095 Instantiate_Package_Body 14096 (Info, Body_Optional => True); 14097 14098 -- Subprogram instance 14099 14100 else 14101 -- The instance_spec is in the wrapper package, 14102 -- usually followed by its local renaming 14103 -- declaration. See Build_Subprogram_Renaming 14104 -- for details. If the instance carries aspects, 14105 -- these result in the corresponding pragmas, 14106 -- inserted after the subprogram declaration. 14107 -- They must be skipped as well when retrieving 14108 -- the desired spec. Some of them may have been 14109 -- rewritten as null statements. 14110 -- A direct link would be more robust ??? 14111 14112 declare 14113 Decl : Node_Id := 14114 (Last (Visible_Declarations 14115 (Specification (Info.Act_Decl)))); 14116 begin 14117 while Nkind_In (Decl, 14118 N_Null_Statement, 14119 N_Pragma, 14120 N_Subprogram_Renaming_Declaration) 14121 loop 14122 Decl := Prev (Decl); 14123 end loop; 14124 14125 Info.Act_Decl := Decl; 14126 end; 14127 14128 Instantiate_Subprogram_Body 14129 (Info, Body_Optional => True); 14130 end if; 14131 14132 Next_Elmt (Decl); 14133 end loop; 14134 end; 14135 end if; 14136 14137 Instantiate_Package_Body 14138 (Body_Info => 14139 ((Act_Decl => True_Parent, 14140 Config_Switches => Save_Config_Switches, 14141 Current_Sem_Unit => 14142 Get_Code_Unit (Sloc (Inst_Node)), 14143 Expander_Status => Exp_Status, 14144 Inst_Node => Inst_Node, 14145 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 14146 Scope_Suppress => Scope_Suppress, 14147 Warnings => Save_Warnings)), 14148 Body_Optional => Body_Optional); 14149 end; 14150 end if; 14151 14152 -- Case where we are not instantiating a nested generic 14153 14154 else 14155 Opt.Style_Check := False; 14156 Expander_Mode_Save_And_Set (True); 14157 Load_Needed_Body (Comp_Unit, OK); 14158 Opt.Style_Check := Saved_Style_Check; 14159 Restore_Warnings (Saved_Warnings); 14160 Expander_Mode_Restore; 14161 14162 if not OK 14163 and then Unit_Requires_Body (Defining_Entity (Spec)) 14164 and then not Body_Optional 14165 then 14166 declare 14167 Bname : constant Unit_Name_Type := 14168 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 14169 14170 begin 14171 -- In CodePeer mode, the missing body may make the analysis 14172 -- incomplete, but we do not treat it as fatal. 14173 14174 if CodePeer_Mode then 14175 return; 14176 14177 else 14178 Error_Msg_Unit_1 := Bname; 14179 Error_Msg_N ("this instantiation requires$!", N); 14180 Error_Msg_File_1 := 14181 Get_File_Name (Bname, Subunit => False); 14182 Error_Msg_N ("\but file{ was not found!", N); 14183 raise Unrecoverable_Error; 14184 end if; 14185 end; 14186 end if; 14187 end if; 14188 end if; 14189 14190 -- If loading parent of the generic caused an instantiation circularity, 14191 -- we abandon compilation at this point, because otherwise in some cases 14192 -- we get into trouble with infinite recursions after this point. 14193 14194 if Circularity_Detected then 14195 raise Unrecoverable_Error; 14196 end if; 14197 end Load_Parent_Of_Generic; 14198 14199 --------------------------------- 14200 -- Map_Formal_Package_Entities -- 14201 --------------------------------- 14202 14203 procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is 14204 E1 : Entity_Id; 14205 E2 : Entity_Id; 14206 14207 begin 14208 Set_Instance_Of (Form, Act); 14209 14210 -- Traverse formal and actual package to map the corresponding entities. 14211 -- We skip over internal entities that may be generated during semantic 14212 -- analysis, and find the matching entities by name, given that they 14213 -- must appear in the same order. 14214 14215 E1 := First_Entity (Form); 14216 E2 := First_Entity (Act); 14217 while Present (E1) and then E1 /= First_Private_Entity (Form) loop 14218 -- Could this test be a single condition??? Seems like it could, and 14219 -- isn't FPE (Form) a constant anyway??? 14220 14221 if not Is_Internal (E1) 14222 and then Present (Parent (E1)) 14223 and then not Is_Class_Wide_Type (E1) 14224 and then not Is_Internal_Name (Chars (E1)) 14225 then 14226 while Present (E2) and then Chars (E2) /= Chars (E1) loop 14227 Next_Entity (E2); 14228 end loop; 14229 14230 if No (E2) then 14231 exit; 14232 else 14233 Set_Instance_Of (E1, E2); 14234 14235 if Is_Type (E1) and then Is_Tagged_Type (E2) then 14236 Set_Instance_Of (Class_Wide_Type (E1), Class_Wide_Type (E2)); 14237 end if; 14238 14239 if Is_Constrained (E1) then 14240 Set_Instance_Of (Base_Type (E1), Base_Type (E2)); 14241 end if; 14242 14243 if Ekind (E1) = E_Package and then No (Renamed_Object (E1)) then 14244 Map_Formal_Package_Entities (E1, E2); 14245 end if; 14246 end if; 14247 end if; 14248 14249 Next_Entity (E1); 14250 end loop; 14251 end Map_Formal_Package_Entities; 14252 14253 ----------------------- 14254 -- Move_Freeze_Nodes -- 14255 ----------------------- 14256 14257 procedure Move_Freeze_Nodes 14258 (Out_Of : Entity_Id; 14259 After : Node_Id; 14260 L : List_Id) 14261 is 14262 Decl : Node_Id; 14263 Next_Decl : Node_Id; 14264 Next_Node : Node_Id := After; 14265 Spec : Node_Id; 14266 14267 function Is_Outer_Type (T : Entity_Id) return Boolean; 14268 -- Check whether entity is declared in a scope external to that of the 14269 -- generic unit. 14270 14271 ------------------- 14272 -- Is_Outer_Type -- 14273 ------------------- 14274 14275 function Is_Outer_Type (T : Entity_Id) return Boolean is 14276 Scop : Entity_Id := Scope (T); 14277 14278 begin 14279 if Scope_Depth (Scop) < Scope_Depth (Out_Of) then 14280 return True; 14281 14282 else 14283 while Scop /= Standard_Standard loop 14284 if Scop = Out_Of then 14285 return False; 14286 else 14287 Scop := Scope (Scop); 14288 end if; 14289 end loop; 14290 14291 return True; 14292 end if; 14293 end Is_Outer_Type; 14294 14295 -- Start of processing for Move_Freeze_Nodes 14296 14297 begin 14298 if No (L) then 14299 return; 14300 end if; 14301 14302 -- First remove the freeze nodes that may appear before all other 14303 -- declarations. 14304 14305 Decl := First (L); 14306 while Present (Decl) 14307 and then Nkind (Decl) = N_Freeze_Entity 14308 and then Is_Outer_Type (Entity (Decl)) 14309 loop 14310 Decl := Remove_Head (L); 14311 Insert_After (Next_Node, Decl); 14312 Set_Analyzed (Decl, False); 14313 Next_Node := Decl; 14314 Decl := First (L); 14315 end loop; 14316 14317 -- Next scan the list of declarations and remove each freeze node that 14318 -- appears ahead of the current node. 14319 14320 while Present (Decl) loop 14321 while Present (Next (Decl)) 14322 and then Nkind (Next (Decl)) = N_Freeze_Entity 14323 and then Is_Outer_Type (Entity (Next (Decl))) 14324 loop 14325 Next_Decl := Remove_Next (Decl); 14326 Insert_After (Next_Node, Next_Decl); 14327 Set_Analyzed (Next_Decl, False); 14328 Next_Node := Next_Decl; 14329 end loop; 14330 14331 -- If the declaration is a nested package or concurrent type, then 14332 -- recurse. Nested generic packages will have been processed from the 14333 -- inside out. 14334 14335 case Nkind (Decl) is 14336 when N_Package_Declaration => 14337 Spec := Specification (Decl); 14338 14339 when N_Task_Type_Declaration => 14340 Spec := Task_Definition (Decl); 14341 14342 when N_Protected_Type_Declaration => 14343 Spec := Protected_Definition (Decl); 14344 14345 when others => 14346 Spec := Empty; 14347 end case; 14348 14349 if Present (Spec) then 14350 Move_Freeze_Nodes (Out_Of, Next_Node, Visible_Declarations (Spec)); 14351 Move_Freeze_Nodes (Out_Of, Next_Node, Private_Declarations (Spec)); 14352 end if; 14353 14354 Next (Decl); 14355 end loop; 14356 end Move_Freeze_Nodes; 14357 14358 ---------------- 14359 -- Next_Assoc -- 14360 ---------------- 14361 14362 function Next_Assoc (E : Assoc_Ptr) return Assoc_Ptr is 14363 begin 14364 return Generic_Renamings.Table (E).Next_In_HTable; 14365 end Next_Assoc; 14366 14367 ------------------------ 14368 -- Preanalyze_Actuals -- 14369 ------------------------ 14370 14371 procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is 14372 procedure Perform_Appropriate_Analysis (N : Node_Id); 14373 -- Determine if the actuals we are analyzing come from a generic 14374 -- instantiation that is a library unit and dispatch accordingly. 14375 14376 ---------------------------------- 14377 -- Perform_Appropriate_Analysis -- 14378 ---------------------------------- 14379 14380 procedure Perform_Appropriate_Analysis (N : Node_Id) is 14381 begin 14382 -- When we have a library instantiation we cannot allow any expansion 14383 -- to occur, since there may be no place to put it. Instead, in that 14384 -- case we perform a preanalysis of the actual. 14385 14386 if Present (Inst) and then Is_Compilation_Unit (Inst) then 14387 Preanalyze (N); 14388 else 14389 Analyze (N); 14390 end if; 14391 end Perform_Appropriate_Analysis; 14392 14393 -- Local variables 14394 14395 Errs : constant Nat := Serious_Errors_Detected; 14396 14397 Assoc : Node_Id; 14398 Act : Node_Id; 14399 14400 Cur : Entity_Id := Empty; 14401 -- Current homograph of the instance name 14402 14403 Vis : Boolean := False; 14404 -- Saved visibility status of the current homograph 14405 14406 -- Start of processing for Preanalyze_Actuals 14407 14408 begin 14409 Assoc := First (Generic_Associations (N)); 14410 14411 -- If the instance is a child unit, its name may hide an outer homonym, 14412 -- so make it invisible to perform name resolution on the actuals. 14413 14414 if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name 14415 and then Present 14416 (Current_Entity (Defining_Identifier (Defining_Unit_Name (N)))) 14417 then 14418 Cur := Current_Entity (Defining_Identifier (Defining_Unit_Name (N))); 14419 14420 if Is_Compilation_Unit (Cur) then 14421 Vis := Is_Immediately_Visible (Cur); 14422 Set_Is_Immediately_Visible (Cur, False); 14423 else 14424 Cur := Empty; 14425 end if; 14426 end if; 14427 14428 while Present (Assoc) loop 14429 if Nkind (Assoc) /= N_Others_Choice then 14430 Act := Explicit_Generic_Actual_Parameter (Assoc); 14431 14432 -- Within a nested instantiation, a defaulted actual is an empty 14433 -- association, so nothing to analyze. If the subprogram actual 14434 -- is an attribute, analyze prefix only, because actual is not a 14435 -- complete attribute reference. 14436 14437 -- If actual is an allocator, analyze expression only. The full 14438 -- analysis can generate code, and if instance is a compilation 14439 -- unit we have to wait until the package instance is installed 14440 -- to have a proper place to insert this code. 14441 14442 -- String literals may be operators, but at this point we do not 14443 -- know whether the actual is a formal subprogram or a string. 14444 14445 if No (Act) then 14446 null; 14447 14448 elsif Nkind (Act) = N_Attribute_Reference then 14449 Perform_Appropriate_Analysis (Prefix (Act)); 14450 14451 elsif Nkind (Act) = N_Explicit_Dereference then 14452 Perform_Appropriate_Analysis (Prefix (Act)); 14453 14454 elsif Nkind (Act) = N_Allocator then 14455 declare 14456 Expr : constant Node_Id := Expression (Act); 14457 14458 begin 14459 if Nkind (Expr) = N_Subtype_Indication then 14460 Perform_Appropriate_Analysis (Subtype_Mark (Expr)); 14461 14462 -- Analyze separately each discriminant constraint, when 14463 -- given with a named association. 14464 14465 declare 14466 Constr : Node_Id; 14467 14468 begin 14469 Constr := First (Constraints (Constraint (Expr))); 14470 while Present (Constr) loop 14471 if Nkind (Constr) = N_Discriminant_Association then 14472 Perform_Appropriate_Analysis 14473 (Expression (Constr)); 14474 else 14475 Perform_Appropriate_Analysis (Constr); 14476 end if; 14477 14478 Next (Constr); 14479 end loop; 14480 end; 14481 14482 else 14483 Perform_Appropriate_Analysis (Expr); 14484 end if; 14485 end; 14486 14487 elsif Nkind (Act) /= N_Operator_Symbol then 14488 Perform_Appropriate_Analysis (Act); 14489 14490 -- Within a package instance, mark actuals that are limited 14491 -- views, so their use can be moved to the body of the 14492 -- enclosing unit. 14493 14494 if Is_Entity_Name (Act) 14495 and then Is_Type (Entity (Act)) 14496 and then From_Limited_With (Entity (Act)) 14497 and then Present (Inst) 14498 then 14499 Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); 14500 end if; 14501 end if; 14502 14503 if Errs /= Serious_Errors_Detected then 14504 14505 -- Do a minimal analysis of the generic, to prevent spurious 14506 -- warnings complaining about the generic being unreferenced, 14507 -- before abandoning the instantiation. 14508 14509 Perform_Appropriate_Analysis (Name (N)); 14510 14511 if Is_Entity_Name (Name (N)) 14512 and then Etype (Name (N)) /= Any_Type 14513 then 14514 Generate_Reference (Entity (Name (N)), Name (N)); 14515 Set_Is_Instantiated (Entity (Name (N))); 14516 end if; 14517 14518 if Present (Cur) then 14519 14520 -- For the case of a child instance hiding an outer homonym, 14521 -- provide additional warning which might explain the error. 14522 14523 Set_Is_Immediately_Visible (Cur, Vis); 14524 Error_Msg_NE 14525 ("& hides outer unit with the same name??", 14526 N, Defining_Unit_Name (N)); 14527 end if; 14528 14529 Abandon_Instantiation (Act); 14530 end if; 14531 end if; 14532 14533 Next (Assoc); 14534 end loop; 14535 14536 if Present (Cur) then 14537 Set_Is_Immediately_Visible (Cur, Vis); 14538 end if; 14539 end Preanalyze_Actuals; 14540 14541 ------------------------------- 14542 -- Provide_Completing_Bodies -- 14543 ------------------------------- 14544 14545 procedure Provide_Completing_Bodies (N : Node_Id) is 14546 procedure Build_Completing_Body (Subp_Decl : Node_Id); 14547 -- Generate the completing body for subprogram declaration Subp_Decl 14548 14549 procedure Provide_Completing_Bodies_In (Decls : List_Id); 14550 -- Generating completing bodies for all subprograms found in declarative 14551 -- list Decls. 14552 14553 --------------------------- 14554 -- Build_Completing_Body -- 14555 --------------------------- 14556 14557 procedure Build_Completing_Body (Subp_Decl : Node_Id) is 14558 Loc : constant Source_Ptr := Sloc (Subp_Decl); 14559 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 14560 Spec : Node_Id; 14561 14562 begin 14563 -- Nothing to do if the subprogram already has a completing body 14564 14565 if Present (Corresponding_Body (Subp_Decl)) then 14566 return; 14567 14568 -- Mark the function as having a valid return statement even though 14569 -- the body contains a single raise statement. 14570 14571 elsif Ekind (Subp_Id) = E_Function then 14572 Set_Return_Present (Subp_Id); 14573 end if; 14574 14575 -- Clone the specification to obtain new entities and reset the only 14576 -- semantic field. 14577 14578 Spec := Copy_Subprogram_Spec (Specification (Subp_Decl)); 14579 Set_Generic_Parent (Spec, Empty); 14580 14581 -- Generate: 14582 -- function Func ... return ... is 14583 -- <or> 14584 -- procedure Proc ... is 14585 -- begin 14586 -- raise Program_Error with "access before elaboration"; 14587 -- edn Proc; 14588 14589 Insert_After_And_Analyze (Subp_Decl, 14590 Make_Subprogram_Body (Loc, 14591 Specification => Spec, 14592 Declarations => New_List, 14593 Handled_Statement_Sequence => 14594 Make_Handled_Sequence_Of_Statements (Loc, 14595 Statements => New_List ( 14596 Make_Raise_Program_Error (Loc, 14597 Reason => PE_Access_Before_Elaboration))))); 14598 end Build_Completing_Body; 14599 14600 ---------------------------------- 14601 -- Provide_Completing_Bodies_In -- 14602 ---------------------------------- 14603 14604 procedure Provide_Completing_Bodies_In (Decls : List_Id) is 14605 Decl : Node_Id; 14606 14607 begin 14608 if Present (Decls) then 14609 Decl := First (Decls); 14610 while Present (Decl) loop 14611 Provide_Completing_Bodies (Decl); 14612 Next (Decl); 14613 end loop; 14614 end if; 14615 end Provide_Completing_Bodies_In; 14616 14617 -- Local variables 14618 14619 Spec : Node_Id; 14620 14621 -- Start of processing for Provide_Completing_Bodies 14622 14623 begin 14624 if Nkind (N) = N_Package_Declaration then 14625 Spec := Specification (N); 14626 14627 Push_Scope (Defining_Entity (N)); 14628 Provide_Completing_Bodies_In (Visible_Declarations (Spec)); 14629 Provide_Completing_Bodies_In (Private_Declarations (Spec)); 14630 Pop_Scope; 14631 14632 elsif Nkind (N) = N_Subprogram_Declaration then 14633 Build_Completing_Body (N); 14634 end if; 14635 end Provide_Completing_Bodies; 14636 14637 ------------------- 14638 -- Remove_Parent -- 14639 ------------------- 14640 14641 procedure Remove_Parent (In_Body : Boolean := False) is 14642 S : Entity_Id := Current_Scope; 14643 -- S is the scope containing the instantiation just completed. The scope 14644 -- stack contains the parent instances of the instantiation, followed by 14645 -- the original S. 14646 14647 Cur_P : Entity_Id; 14648 E : Entity_Id; 14649 P : Entity_Id; 14650 Hidden : Elmt_Id; 14651 14652 begin 14653 -- After child instantiation is complete, remove from scope stack the 14654 -- extra copy of the current scope, and then remove parent instances. 14655 14656 if not In_Body then 14657 Pop_Scope; 14658 14659 while Current_Scope /= S loop 14660 P := Current_Scope; 14661 End_Package_Scope (Current_Scope); 14662 14663 if In_Open_Scopes (P) then 14664 E := First_Entity (P); 14665 while Present (E) loop 14666 Set_Is_Immediately_Visible (E, True); 14667 Next_Entity (E); 14668 end loop; 14669 14670 -- If instantiation is declared in a block, it is the enclosing 14671 -- scope that might be a parent instance. Note that only one 14672 -- block can be involved, because the parent instances have 14673 -- been installed within it. 14674 14675 if Ekind (P) = E_Block then 14676 Cur_P := Scope (P); 14677 else 14678 Cur_P := P; 14679 end if; 14680 14681 if Is_Generic_Instance (Cur_P) and then P /= Current_Scope then 14682 -- We are within an instance of some sibling. Retain 14683 -- visibility of parent, for proper subsequent cleanup, and 14684 -- reinstall private declarations as well. 14685 14686 Set_In_Private_Part (P); 14687 Install_Private_Declarations (P); 14688 end if; 14689 14690 -- If the ultimate parent is a top-level unit recorded in 14691 -- Instance_Parent_Unit, then reset its visibility to what it was 14692 -- before instantiation. (It's not clear what the purpose is of 14693 -- testing whether Scope (P) is In_Open_Scopes, but that test was 14694 -- present before the ultimate parent test was added.???) 14695 14696 elsif not In_Open_Scopes (Scope (P)) 14697 or else (P = Instance_Parent_Unit 14698 and then not Parent_Unit_Visible) 14699 then 14700 Set_Is_Immediately_Visible (P, False); 14701 14702 -- If the current scope is itself an instantiation of a generic 14703 -- nested within P, and we are in the private part of body of this 14704 -- instantiation, restore the full views of P, that were removed 14705 -- in End_Package_Scope above. This obscure case can occur when a 14706 -- subunit of a generic contains an instance of a child unit of 14707 -- its generic parent unit. 14708 14709 elsif S = Current_Scope and then Is_Generic_Instance (S) then 14710 declare 14711 Par : constant Entity_Id := 14712 Generic_Parent (Package_Specification (S)); 14713 begin 14714 if Present (Par) 14715 and then P = Scope (Par) 14716 and then (In_Package_Body (S) or else In_Private_Part (S)) 14717 then 14718 Set_In_Private_Part (P); 14719 Install_Private_Declarations (P); 14720 end if; 14721 end; 14722 end if; 14723 end loop; 14724 14725 -- Reset visibility of entities in the enclosing scope 14726 14727 Set_Is_Hidden_Open_Scope (Current_Scope, False); 14728 14729 Hidden := First_Elmt (Hidden_Entities); 14730 while Present (Hidden) loop 14731 Set_Is_Immediately_Visible (Node (Hidden), True); 14732 Next_Elmt (Hidden); 14733 end loop; 14734 14735 else 14736 -- Each body is analyzed separately, and there is no context that 14737 -- needs preserving from one body instance to the next, so remove all 14738 -- parent scopes that have been installed. 14739 14740 while Present (S) loop 14741 End_Package_Scope (S); 14742 Set_Is_Immediately_Visible (S, False); 14743 S := Current_Scope; 14744 exit when S = Standard_Standard; 14745 end loop; 14746 end if; 14747 end Remove_Parent; 14748 14749 ----------------- 14750 -- Restore_Env -- 14751 ----------------- 14752 14753 procedure Restore_Env is 14754 Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); 14755 14756 begin 14757 if No (Current_Instantiated_Parent.Act_Id) then 14758 -- Restore environment after subprogram inlining 14759 14760 Restore_Private_Views (Empty); 14761 end if; 14762 14763 Current_Instantiated_Parent := Saved.Instantiated_Parent; 14764 Exchanged_Views := Saved.Exchanged_Views; 14765 Hidden_Entities := Saved.Hidden_Entities; 14766 Current_Sem_Unit := Saved.Current_Sem_Unit; 14767 Parent_Unit_Visible := Saved.Parent_Unit_Visible; 14768 Instance_Parent_Unit := Saved.Instance_Parent_Unit; 14769 14770 Restore_Config_Switches (Saved.Switches); 14771 14772 Instance_Envs.Decrement_Last; 14773 end Restore_Env; 14774 14775 --------------------------- 14776 -- Restore_Private_Views -- 14777 --------------------------- 14778 14779 procedure Restore_Private_Views 14780 (Pack_Id : Entity_Id; 14781 Is_Package : Boolean := True) 14782 is 14783 M : Elmt_Id; 14784 E : Entity_Id; 14785 Typ : Entity_Id; 14786 Dep_Elmt : Elmt_Id; 14787 Dep_Typ : Node_Id; 14788 14789 procedure Restore_Nested_Formal (Formal : Entity_Id); 14790 -- Hide the generic formals of formal packages declared with box which 14791 -- were reachable in the current instantiation. 14792 14793 --------------------------- 14794 -- Restore_Nested_Formal -- 14795 --------------------------- 14796 14797 procedure Restore_Nested_Formal (Formal : Entity_Id) is 14798 Ent : Entity_Id; 14799 14800 begin 14801 if Present (Renamed_Object (Formal)) 14802 and then Denotes_Formal_Package (Renamed_Object (Formal), True) 14803 then 14804 return; 14805 14806 elsif Present (Associated_Formal_Package (Formal)) then 14807 Ent := First_Entity (Formal); 14808 while Present (Ent) loop 14809 exit when Ekind (Ent) = E_Package 14810 and then Renamed_Entity (Ent) = Renamed_Entity (Formal); 14811 14812 Set_Is_Hidden (Ent); 14813 Set_Is_Potentially_Use_Visible (Ent, False); 14814 14815 -- If package, then recurse 14816 14817 if Ekind (Ent) = E_Package then 14818 Restore_Nested_Formal (Ent); 14819 end if; 14820 14821 Next_Entity (Ent); 14822 end loop; 14823 end if; 14824 end Restore_Nested_Formal; 14825 14826 -- Start of processing for Restore_Private_Views 14827 14828 begin 14829 M := First_Elmt (Exchanged_Views); 14830 while Present (M) loop 14831 Typ := Node (M); 14832 14833 -- Subtypes of types whose views have been exchanged, and that are 14834 -- defined within the instance, were not on the Private_Dependents 14835 -- list on entry to the instance, so they have to be exchanged 14836 -- explicitly now, in order to remain consistent with the view of the 14837 -- parent type. 14838 14839 if Ekind_In (Typ, E_Private_Type, 14840 E_Limited_Private_Type, 14841 E_Record_Type_With_Private) 14842 then 14843 Dep_Elmt := First_Elmt (Private_Dependents (Typ)); 14844 while Present (Dep_Elmt) loop 14845 Dep_Typ := Node (Dep_Elmt); 14846 14847 if Scope (Dep_Typ) = Pack_Id 14848 and then Present (Full_View (Dep_Typ)) 14849 then 14850 Replace_Elmt (Dep_Elmt, Full_View (Dep_Typ)); 14851 Exchange_Declarations (Dep_Typ); 14852 end if; 14853 14854 Next_Elmt (Dep_Elmt); 14855 end loop; 14856 end if; 14857 14858 Exchange_Declarations (Node (M)); 14859 Next_Elmt (M); 14860 end loop; 14861 14862 if No (Pack_Id) then 14863 return; 14864 end if; 14865 14866 -- Make the generic formal parameters private, and make the formal types 14867 -- into subtypes of the actuals again. 14868 14869 E := First_Entity (Pack_Id); 14870 while Present (E) loop 14871 Set_Is_Hidden (E, True); 14872 14873 if Is_Type (E) 14874 and then Nkind (Parent (E)) = N_Subtype_Declaration 14875 then 14876 -- If the actual for E is itself a generic actual type from 14877 -- an enclosing instance, E is still a generic actual type 14878 -- outside of the current instance. This matter when resolving 14879 -- an overloaded call that may be ambiguous in the enclosing 14880 -- instance, when two of its actuals coincide. 14881 14882 if Is_Entity_Name (Subtype_Indication (Parent (E))) 14883 and then Is_Generic_Actual_Type 14884 (Entity (Subtype_Indication (Parent (E)))) 14885 then 14886 null; 14887 else 14888 Set_Is_Generic_Actual_Type (E, False); 14889 14890 -- It might seem reasonable to clear the Is_Generic_Actual_Type 14891 -- flag also on the Full_View if the type is private, since it 14892 -- was set also on this Full_View. However, this flag is relied 14893 -- upon by Covers to spot "types exported from instantiations" 14894 -- which are implicit Full_Views built for instantiations made 14895 -- on private types and we get type mismatches if we do it when 14896 -- the block exchanging the declarations below triggers ??? 14897 14898 -- if Is_Private_Type (E) and then Present (Full_View (E)) then 14899 -- Set_Is_Generic_Actual_Type (Full_View (E), False); 14900 -- end if; 14901 end if; 14902 14903 -- An unusual case of aliasing: the actual may also be directly 14904 -- visible in the generic, and be private there, while it is fully 14905 -- visible in the context of the instance. The internal subtype 14906 -- is private in the instance but has full visibility like its 14907 -- parent in the enclosing scope. This enforces the invariant that 14908 -- the privacy status of all private dependents of a type coincide 14909 -- with that of the parent type. This can only happen when a 14910 -- generic child unit is instantiated within a sibling. 14911 14912 if Is_Private_Type (E) 14913 and then not Is_Private_Type (Etype (E)) 14914 then 14915 Exchange_Declarations (E); 14916 end if; 14917 14918 elsif Ekind (E) = E_Package then 14919 14920 -- The end of the renaming list is the renaming of the generic 14921 -- package itself. If the instance is a subprogram, all entities 14922 -- in the corresponding package are renamings. If this entity is 14923 -- a formal package, make its own formals private as well. The 14924 -- actual in this case is itself the renaming of an instantiation. 14925 -- If the entity is not a package renaming, it is the entity 14926 -- created to validate formal package actuals: ignore it. 14927 14928 -- If the actual is itself a formal package for the enclosing 14929 -- generic, or the actual for such a formal package, it remains 14930 -- visible on exit from the instance, and therefore nothing needs 14931 -- to be done either, except to keep it accessible. 14932 14933 if Is_Package and then Renamed_Object (E) = Pack_Id then 14934 exit; 14935 14936 elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then 14937 null; 14938 14939 elsif 14940 Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id) 14941 then 14942 Set_Is_Hidden (E, False); 14943 14944 else 14945 declare 14946 Act_P : constant Entity_Id := Renamed_Object (E); 14947 Id : Entity_Id; 14948 14949 begin 14950 Id := First_Entity (Act_P); 14951 while Present (Id) 14952 and then Id /= First_Private_Entity (Act_P) 14953 loop 14954 exit when Ekind (Id) = E_Package 14955 and then Renamed_Object (Id) = Act_P; 14956 14957 Set_Is_Hidden (Id, True); 14958 Set_Is_Potentially_Use_Visible (Id, In_Use (Act_P)); 14959 14960 if Ekind (Id) = E_Package then 14961 Restore_Nested_Formal (Id); 14962 end if; 14963 14964 Next_Entity (Id); 14965 end loop; 14966 end; 14967 end if; 14968 end if; 14969 14970 Next_Entity (E); 14971 end loop; 14972 end Restore_Private_Views; 14973 14974 -------------- 14975 -- Save_Env -- 14976 -------------- 14977 14978 procedure Save_Env 14979 (Gen_Unit : Entity_Id; 14980 Act_Unit : Entity_Id) 14981 is 14982 begin 14983 Init_Env; 14984 Set_Instance_Env (Gen_Unit, Act_Unit); 14985 end Save_Env; 14986 14987 ---------------------------- 14988 -- Save_Global_References -- 14989 ---------------------------- 14990 14991 procedure Save_Global_References (Templ : Node_Id) is 14992 14993 -- ??? it is horrible to use global variables in highly recursive code 14994 14995 E : Entity_Id; 14996 -- The entity of the current associated node 14997 14998 Gen_Scope : Entity_Id; 14999 -- The scope of the generic for which references are being saved 15000 15001 N2 : Node_Id; 15002 -- The current associated node 15003 15004 function Is_Global (E : Entity_Id) return Boolean; 15005 -- Check whether entity is defined outside of generic unit. Examine the 15006 -- scope of an entity, and the scope of the scope, etc, until we find 15007 -- either Standard, in which case the entity is global, or the generic 15008 -- unit itself, which indicates that the entity is local. If the entity 15009 -- is the generic unit itself, as in the case of a recursive call, or 15010 -- the enclosing generic unit, if different from the current scope, then 15011 -- it is local as well, because it will be replaced at the point of 15012 -- instantiation. On the other hand, if it is a reference to a child 15013 -- unit of a common ancestor, which appears in an instantiation, it is 15014 -- global because it is used to denote a specific compilation unit at 15015 -- the time the instantiations will be analyzed. 15016 15017 procedure Qualify_Universal_Operands 15018 (Op : Node_Id; 15019 Func_Call : Node_Id); 15020 -- Op denotes a binary or unary operator in generic template Templ. Node 15021 -- Func_Call is the function call alternative of the operator within the 15022 -- the analyzed copy of the template. Change each operand which yields a 15023 -- universal type by wrapping it into a qualified expression 15024 -- 15025 -- Actual_Typ'(Operand) 15026 -- 15027 -- where Actual_Typ is the type of corresponding actual parameter of 15028 -- Operand in Func_Call. 15029 15030 procedure Reset_Entity (N : Node_Id); 15031 -- Save semantic information on global entity so that it is not resolved 15032 -- again at instantiation time. 15033 15034 procedure Save_Entity_Descendants (N : Node_Id); 15035 -- Apply Save_Global_References to the two syntactic descendants of 15036 -- non-terminal nodes that carry an Associated_Node and are processed 15037 -- through Reset_Entity. Once the global entity (if any) has been 15038 -- captured together with its type, only two syntactic descendants need 15039 -- to be traversed to complete the processing of the tree rooted at N. 15040 -- This applies to Selected_Components, Expanded_Names, and to Operator 15041 -- nodes. N can also be a character literal, identifier, or operator 15042 -- symbol node, but the call has no effect in these cases. 15043 15044 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id); 15045 -- Default actuals in nested instances must be handled specially 15046 -- because there is no link to them from the original tree. When an 15047 -- actual subprogram is given by a default, we add an explicit generic 15048 -- association for it in the instantiation node. When we save the 15049 -- global references on the name of the instance, we recover the list 15050 -- of generic associations, and add an explicit one to the original 15051 -- generic tree, through which a global actual can be preserved. 15052 -- Similarly, if a child unit is instantiated within a sibling, in the 15053 -- context of the parent, we must preserve the identifier of the parent 15054 -- so that it can be properly resolved in a subsequent instantiation. 15055 15056 procedure Save_Global_Descendant (D : Union_Id); 15057 -- Apply Save_References recursively to the descendants of node D 15058 15059 procedure Save_References (N : Node_Id); 15060 -- This is the recursive procedure that does the work, once the 15061 -- enclosing generic scope has been established. 15062 15063 --------------- 15064 -- Is_Global -- 15065 --------------- 15066 15067 function Is_Global (E : Entity_Id) return Boolean is 15068 Se : Entity_Id; 15069 15070 function Is_Instance_Node (Decl : Node_Id) return Boolean; 15071 -- Determine whether the parent node of a reference to a child unit 15072 -- denotes an instantiation or a formal package, in which case the 15073 -- reference to the child unit is global, even if it appears within 15074 -- the current scope (e.g. when the instance appears within the body 15075 -- of an ancestor). 15076 15077 ---------------------- 15078 -- Is_Instance_Node -- 15079 ---------------------- 15080 15081 function Is_Instance_Node (Decl : Node_Id) return Boolean is 15082 begin 15083 return Nkind (Decl) in N_Generic_Instantiation 15084 or else 15085 Nkind (Original_Node (Decl)) = N_Formal_Package_Declaration; 15086 end Is_Instance_Node; 15087 15088 -- Start of processing for Is_Global 15089 15090 begin 15091 if E = Gen_Scope then 15092 return False; 15093 15094 elsif E = Standard_Standard then 15095 return True; 15096 15097 elsif Is_Child_Unit (E) 15098 and then (Is_Instance_Node (Parent (N2)) 15099 or else (Nkind (Parent (N2)) = N_Expanded_Name 15100 and then N2 = Selector_Name (Parent (N2)) 15101 and then 15102 Is_Instance_Node (Parent (Parent (N2))))) 15103 then 15104 return True; 15105 15106 else 15107 Se := Scope (E); 15108 while Se /= Gen_Scope loop 15109 if Se = Standard_Standard then 15110 return True; 15111 else 15112 Se := Scope (Se); 15113 end if; 15114 end loop; 15115 15116 return False; 15117 end if; 15118 end Is_Global; 15119 15120 -------------------------------- 15121 -- Qualify_Universal_Operands -- 15122 -------------------------------- 15123 15124 procedure Qualify_Universal_Operands 15125 (Op : Node_Id; 15126 Func_Call : Node_Id) 15127 is 15128 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id); 15129 -- Rewrite operand Opnd as a qualified expression of the form 15130 -- 15131 -- Actual_Typ'(Opnd) 15132 -- 15133 -- where Actual is the corresponding actual parameter of Opnd in 15134 -- function call Func_Call. 15135 15136 function Qualify_Type 15137 (Loc : Source_Ptr; 15138 Typ : Entity_Id) return Node_Id; 15139 -- Qualify type Typ by creating a selected component of the form 15140 -- 15141 -- Scope_Of_Typ.Typ 15142 15143 --------------------- 15144 -- Qualify_Operand -- 15145 --------------------- 15146 15147 procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is 15148 Loc : constant Source_Ptr := Sloc (Opnd); 15149 Typ : constant Entity_Id := Etype (Actual); 15150 Mark : Node_Id; 15151 Qual : Node_Id; 15152 15153 begin 15154 -- Qualify the operand when it is of a universal type. Note that 15155 -- the template is unanalyzed and it is not possible to directly 15156 -- query the type. This transformation is not done when the type 15157 -- of the actual is internally generated because the type will be 15158 -- regenerated in the instance. 15159 15160 if Yields_Universal_Type (Opnd) 15161 and then Comes_From_Source (Typ) 15162 and then not Is_Hidden (Typ) 15163 then 15164 -- The type of the actual may be a global reference. Save this 15165 -- information by creating a reference to it. 15166 15167 if Is_Global (Typ) then 15168 Mark := New_Occurrence_Of (Typ, Loc); 15169 15170 -- Otherwise rely on resolution to find the proper type within 15171 -- the instance. 15172 15173 else 15174 Mark := Qualify_Type (Loc, Typ); 15175 end if; 15176 15177 Qual := 15178 Make_Qualified_Expression (Loc, 15179 Subtype_Mark => Mark, 15180 Expression => Relocate_Node (Opnd)); 15181 15182 -- Mark the qualification to distinguish it from other source 15183 -- constructs and signal the instantiation mechanism that this 15184 -- node requires special processing. See Copy_Generic_Node for 15185 -- details. 15186 15187 Set_Is_Qualified_Universal_Literal (Qual); 15188 15189 Rewrite (Opnd, Qual); 15190 end if; 15191 end Qualify_Operand; 15192 15193 ------------------ 15194 -- Qualify_Type -- 15195 ------------------ 15196 15197 function Qualify_Type 15198 (Loc : Source_Ptr; 15199 Typ : Entity_Id) return Node_Id 15200 is 15201 Scop : constant Entity_Id := Scope (Typ); 15202 Result : Node_Id; 15203 15204 begin 15205 Result := Make_Identifier (Loc, Chars (Typ)); 15206 15207 if Present (Scop) and then not Is_Generic_Unit (Scop) then 15208 Result := 15209 Make_Selected_Component (Loc, 15210 Prefix => Make_Identifier (Loc, Chars (Scop)), 15211 Selector_Name => Result); 15212 end if; 15213 15214 return Result; 15215 end Qualify_Type; 15216 15217 -- Local variables 15218 15219 Actuals : constant List_Id := Parameter_Associations (Func_Call); 15220 15221 -- Start of processing for Qualify_Universal_Operands 15222 15223 begin 15224 if Nkind (Op) in N_Binary_Op then 15225 Qualify_Operand (Left_Opnd (Op), First (Actuals)); 15226 Qualify_Operand (Right_Opnd (Op), Next (First (Actuals))); 15227 15228 elsif Nkind (Op) in N_Unary_Op then 15229 Qualify_Operand (Right_Opnd (Op), First (Actuals)); 15230 end if; 15231 end Qualify_Universal_Operands; 15232 15233 ------------------ 15234 -- Reset_Entity -- 15235 ------------------ 15236 15237 procedure Reset_Entity (N : Node_Id) is 15238 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); 15239 -- If the type of N2 is global to the generic unit, save the type in 15240 -- the generic node. Just as we perform name capture for explicit 15241 -- references within the generic, we must capture the global types 15242 -- of local entities because they may participate in resolution in 15243 -- the instance. 15244 15245 function Top_Ancestor (E : Entity_Id) return Entity_Id; 15246 -- Find the ultimate ancestor of the current unit. If it is not a 15247 -- generic unit, then the name of the current unit in the prefix of 15248 -- an expanded name must be replaced with its generic homonym to 15249 -- ensure that it will be properly resolved in an instance. 15250 15251 --------------------- 15252 -- Set_Global_Type -- 15253 --------------------- 15254 15255 procedure Set_Global_Type (N : Node_Id; N2 : Node_Id) is 15256 Typ : constant Entity_Id := Etype (N2); 15257 15258 begin 15259 Set_Etype (N, Typ); 15260 15261 -- If the entity of N is not the associated node, this is a 15262 -- nested generic and it has an associated node as well, whose 15263 -- type is already the full view (see below). Indicate that the 15264 -- original node has a private view. 15265 15266 if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then 15267 Set_Has_Private_View (N); 15268 end if; 15269 15270 -- If not a private type, nothing else to do 15271 15272 if not Is_Private_Type (Typ) then 15273 if Is_Array_Type (Typ) 15274 and then Is_Private_Type (Component_Type (Typ)) 15275 then 15276 Set_Has_Private_View (N); 15277 end if; 15278 15279 -- If it is a derivation of a private type in a context where no 15280 -- full view is needed, nothing to do either. 15281 15282 elsif No (Full_View (Typ)) and then Typ /= Etype (Typ) then 15283 null; 15284 15285 -- Otherwise mark the type for flipping and use the full view when 15286 -- available. 15287 15288 else 15289 Set_Has_Private_View (N); 15290 15291 if Present (Full_View (Typ)) then 15292 Set_Etype (N2, Full_View (Typ)); 15293 end if; 15294 end if; 15295 15296 if Is_Floating_Point_Type (Typ) 15297 and then Has_Dimension_System (Typ) 15298 then 15299 Copy_Dimensions (N2, N); 15300 end if; 15301 end Set_Global_Type; 15302 15303 ------------------ 15304 -- Top_Ancestor -- 15305 ------------------ 15306 15307 function Top_Ancestor (E : Entity_Id) return Entity_Id is 15308 Par : Entity_Id; 15309 15310 begin 15311 Par := E; 15312 while Is_Child_Unit (Par) loop 15313 Par := Scope (Par); 15314 end loop; 15315 15316 return Par; 15317 end Top_Ancestor; 15318 15319 -- Start of processing for Reset_Entity 15320 15321 begin 15322 N2 := Get_Associated_Node (N); 15323 E := Entity (N2); 15324 15325 if Present (E) then 15326 15327 -- If the node is an entry call to an entry in an enclosing task, 15328 -- it is rewritten as a selected component. No global entity to 15329 -- preserve in this case, since the expansion will be redone in 15330 -- the instance. 15331 15332 if not Nkind_In (E, N_Defining_Character_Literal, 15333 N_Defining_Identifier, 15334 N_Defining_Operator_Symbol) 15335 then 15336 Set_Associated_Node (N, Empty); 15337 Set_Etype (N, Empty); 15338 return; 15339 end if; 15340 15341 -- If the entity is an itype created as a subtype of an access 15342 -- type with a null exclusion restore source entity for proper 15343 -- visibility. The itype will be created anew in the instance. 15344 15345 if Is_Itype (E) 15346 and then Ekind (E) = E_Access_Subtype 15347 and then Is_Entity_Name (N) 15348 and then Chars (Etype (E)) = Chars (N) 15349 then 15350 E := Etype (E); 15351 Set_Entity (N2, E); 15352 Set_Etype (N2, E); 15353 end if; 15354 15355 if Is_Global (E) then 15356 15357 -- If the entity is a package renaming that is the prefix of 15358 -- an expanded name, it has been rewritten as the renamed 15359 -- package, which is necessary semantically but complicates 15360 -- ASIS tree traversal, so we recover the original entity to 15361 -- expose the renaming. Take into account that the context may 15362 -- be a nested generic, that the original node may itself have 15363 -- an associated node that had better be an entity, and that 15364 -- the current node is still a selected component. 15365 15366 if Ekind (E) = E_Package 15367 and then Nkind (N) = N_Selected_Component 15368 and then Nkind (Parent (N)) = N_Expanded_Name 15369 and then Present (Original_Node (N2)) 15370 and then Is_Entity_Name (Original_Node (N2)) 15371 and then Present (Entity (Original_Node (N2))) 15372 then 15373 if Is_Global (Entity (Original_Node (N2))) then 15374 N2 := Original_Node (N2); 15375 Set_Associated_Node (N, N2); 15376 Set_Global_Type (N, N2); 15377 15378 -- Renaming is local, and will be resolved in instance 15379 15380 else 15381 Set_Associated_Node (N, Empty); 15382 Set_Etype (N, Empty); 15383 end if; 15384 15385 else 15386 Set_Global_Type (N, N2); 15387 end if; 15388 15389 elsif Nkind (N) = N_Op_Concat 15390 and then Is_Generic_Type (Etype (N2)) 15391 and then (Base_Type (Etype (Right_Opnd (N2))) = Etype (N2) 15392 or else 15393 Base_Type (Etype (Left_Opnd (N2))) = Etype (N2)) 15394 and then Is_Intrinsic_Subprogram (E) 15395 then 15396 null; 15397 15398 -- Entity is local. Mark generic node as unresolved. Note that now 15399 -- it does not have an entity. 15400 15401 else 15402 Set_Associated_Node (N, Empty); 15403 Set_Etype (N, Empty); 15404 end if; 15405 15406 if Nkind (Parent (N)) in N_Generic_Instantiation 15407 and then N = Name (Parent (N)) 15408 then 15409 Save_Global_Defaults (Parent (N), Parent (N2)); 15410 end if; 15411 15412 elsif Nkind (Parent (N)) = N_Selected_Component 15413 and then Nkind (Parent (N2)) = N_Expanded_Name 15414 then 15415 if Is_Global (Entity (Parent (N2))) then 15416 Change_Selected_Component_To_Expanded_Name (Parent (N)); 15417 Set_Associated_Node (Parent (N), Parent (N2)); 15418 Set_Global_Type (Parent (N), Parent (N2)); 15419 Save_Entity_Descendants (N); 15420 15421 -- If this is a reference to the current generic entity, replace 15422 -- by the name of the generic homonym of the current package. This 15423 -- is because in an instantiation Par.P.Q will not resolve to the 15424 -- name of the instance, whose enclosing scope is not necessarily 15425 -- Par. We use the generic homonym rather that the name of the 15426 -- generic itself because it may be hidden by a local declaration. 15427 15428 elsif In_Open_Scopes (Entity (Parent (N2))) 15429 and then not 15430 Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2))))) 15431 then 15432 if Ekind (Entity (Parent (N2))) = E_Generic_Package then 15433 Rewrite (Parent (N), 15434 Make_Identifier (Sloc (N), 15435 Chars => 15436 Chars (Generic_Homonym (Entity (Parent (N2)))))); 15437 else 15438 Rewrite (Parent (N), 15439 Make_Identifier (Sloc (N), 15440 Chars => Chars (Selector_Name (Parent (N2))))); 15441 end if; 15442 end if; 15443 15444 if Nkind (Parent (Parent (N))) in N_Generic_Instantiation 15445 and then Parent (N) = Name (Parent (Parent (N))) 15446 then 15447 Save_Global_Defaults 15448 (Parent (Parent (N)), Parent (Parent (N2))); 15449 end if; 15450 15451 -- A selected component may denote a static constant that has been 15452 -- folded. If the static constant is global to the generic, capture 15453 -- its value. Otherwise the folding will happen in any instantiation. 15454 15455 elsif Nkind (Parent (N)) = N_Selected_Component 15456 and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal) 15457 then 15458 if Present (Entity (Original_Node (Parent (N2)))) 15459 and then Is_Global (Entity (Original_Node (Parent (N2)))) 15460 then 15461 Rewrite (Parent (N), New_Copy (Parent (N2))); 15462 Set_Analyzed (Parent (N), False); 15463 end if; 15464 15465 -- A selected component may be transformed into a parameterless 15466 -- function call. If the called entity is global, rewrite the node 15467 -- appropriately, i.e. as an extended name for the global entity. 15468 15469 elsif Nkind (Parent (N)) = N_Selected_Component 15470 and then Nkind (Parent (N2)) = N_Function_Call 15471 and then N = Selector_Name (Parent (N)) 15472 then 15473 if No (Parameter_Associations (Parent (N2))) then 15474 if Is_Global (Entity (Name (Parent (N2)))) then 15475 Change_Selected_Component_To_Expanded_Name (Parent (N)); 15476 Set_Associated_Node (Parent (N), Name (Parent (N2))); 15477 Set_Global_Type (Parent (N), Name (Parent (N2))); 15478 Save_Entity_Descendants (N); 15479 15480 else 15481 Set_Is_Prefixed_Call (Parent (N)); 15482 Set_Associated_Node (N, Empty); 15483 Set_Etype (N, Empty); 15484 end if; 15485 15486 -- In Ada 2005, X.F may be a call to a primitive operation, 15487 -- rewritten as F (X). This rewriting will be done again in an 15488 -- instance, so keep the original node. Global entities will be 15489 -- captured as for other constructs. Indicate that this must 15490 -- resolve as a call, to prevent accidental overloading in the 15491 -- instance, if both a component and a primitive operation appear 15492 -- as candidates. 15493 15494 else 15495 Set_Is_Prefixed_Call (Parent (N)); 15496 end if; 15497 15498 -- Entity is local. Reset in generic unit, so that node is resolved 15499 -- anew at the point of instantiation. 15500 15501 else 15502 Set_Associated_Node (N, Empty); 15503 Set_Etype (N, Empty); 15504 end if; 15505 end Reset_Entity; 15506 15507 ----------------------------- 15508 -- Save_Entity_Descendants -- 15509 ----------------------------- 15510 15511 procedure Save_Entity_Descendants (N : Node_Id) is 15512 begin 15513 case Nkind (N) is 15514 when N_Binary_Op => 15515 Save_Global_Descendant (Union_Id (Left_Opnd (N))); 15516 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15517 15518 when N_Unary_Op => 15519 Save_Global_Descendant (Union_Id (Right_Opnd (N))); 15520 15521 when N_Expanded_Name 15522 | N_Selected_Component 15523 => 15524 Save_Global_Descendant (Union_Id (Prefix (N))); 15525 Save_Global_Descendant (Union_Id (Selector_Name (N))); 15526 15527 when N_Character_Literal 15528 | N_Identifier 15529 | N_Operator_Symbol 15530 => 15531 null; 15532 15533 when others => 15534 raise Program_Error; 15535 end case; 15536 end Save_Entity_Descendants; 15537 15538 -------------------------- 15539 -- Save_Global_Defaults -- 15540 -------------------------- 15541 15542 procedure Save_Global_Defaults (N1 : Node_Id; N2 : Node_Id) is 15543 Loc : constant Source_Ptr := Sloc (N1); 15544 Assoc2 : constant List_Id := Generic_Associations (N2); 15545 Gen_Id : constant Entity_Id := Get_Generic_Entity (N2); 15546 Assoc1 : List_Id; 15547 Act1 : Node_Id; 15548 Act2 : Node_Id; 15549 Def : Node_Id; 15550 Ndec : Node_Id; 15551 Subp : Entity_Id; 15552 Actual : Entity_Id; 15553 15554 begin 15555 Assoc1 := Generic_Associations (N1); 15556 15557 if Present (Assoc1) then 15558 Act1 := First (Assoc1); 15559 else 15560 Act1 := Empty; 15561 Set_Generic_Associations (N1, New_List); 15562 Assoc1 := Generic_Associations (N1); 15563 end if; 15564 15565 if Present (Assoc2) then 15566 Act2 := First (Assoc2); 15567 else 15568 return; 15569 end if; 15570 15571 while Present (Act1) and then Present (Act2) loop 15572 Next (Act1); 15573 Next (Act2); 15574 end loop; 15575 15576 -- Find the associations added for default subprograms 15577 15578 if Present (Act2) then 15579 while Nkind (Act2) /= N_Generic_Association 15580 or else No (Entity (Selector_Name (Act2))) 15581 or else not Is_Overloadable (Entity (Selector_Name (Act2))) 15582 loop 15583 Next (Act2); 15584 end loop; 15585 15586 -- Add a similar association if the default is global. The 15587 -- renaming declaration for the actual has been analyzed, and 15588 -- its alias is the program it renames. Link the actual in the 15589 -- original generic tree with the node in the analyzed tree. 15590 15591 while Present (Act2) loop 15592 Subp := Entity (Selector_Name (Act2)); 15593 Def := Explicit_Generic_Actual_Parameter (Act2); 15594 15595 -- Following test is defence against rubbish errors 15596 15597 if No (Alias (Subp)) then 15598 return; 15599 end if; 15600 15601 -- Retrieve the resolved actual from the renaming declaration 15602 -- created for the instantiated formal. 15603 15604 Actual := Entity (Name (Parent (Parent (Subp)))); 15605 Set_Entity (Def, Actual); 15606 Set_Etype (Def, Etype (Actual)); 15607 15608 if Is_Global (Actual) then 15609 Ndec := 15610 Make_Generic_Association (Loc, 15611 Selector_Name => 15612 New_Occurrence_Of (Subp, Loc), 15613 Explicit_Generic_Actual_Parameter => 15614 New_Occurrence_Of (Actual, Loc)); 15615 15616 Set_Associated_Node 15617 (Explicit_Generic_Actual_Parameter (Ndec), Def); 15618 15619 Append (Ndec, Assoc1); 15620 15621 -- If there are other defaults, add a dummy association in case 15622 -- there are other defaulted formals with the same name. 15623 15624 elsif Present (Next (Act2)) then 15625 Ndec := 15626 Make_Generic_Association (Loc, 15627 Selector_Name => 15628 New_Occurrence_Of (Subp, Loc), 15629 Explicit_Generic_Actual_Parameter => Empty); 15630 15631 Append (Ndec, Assoc1); 15632 end if; 15633 15634 Next (Act2); 15635 end loop; 15636 end if; 15637 15638 if Nkind (Name (N1)) = N_Identifier 15639 and then Is_Child_Unit (Gen_Id) 15640 and then Is_Global (Gen_Id) 15641 and then Is_Generic_Unit (Scope (Gen_Id)) 15642 and then In_Open_Scopes (Scope (Gen_Id)) 15643 then 15644 -- This is an instantiation of a child unit within a sibling, so 15645 -- that the generic parent is in scope. An eventual instance must 15646 -- occur within the scope of an instance of the parent. Make name 15647 -- in instance into an expanded name, to preserve the identifier 15648 -- of the parent, so it can be resolved subsequently. 15649 15650 Rewrite (Name (N2), 15651 Make_Expanded_Name (Loc, 15652 Chars => Chars (Gen_Id), 15653 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15654 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15655 Set_Entity (Name (N2), Gen_Id); 15656 15657 Rewrite (Name (N1), 15658 Make_Expanded_Name (Loc, 15659 Chars => Chars (Gen_Id), 15660 Prefix => New_Occurrence_Of (Scope (Gen_Id), Loc), 15661 Selector_Name => New_Occurrence_Of (Gen_Id, Loc))); 15662 15663 Set_Associated_Node (Name (N1), Name (N2)); 15664 Set_Associated_Node (Prefix (Name (N1)), Empty); 15665 Set_Associated_Node 15666 (Selector_Name (Name (N1)), Selector_Name (Name (N2))); 15667 Set_Etype (Name (N1), Etype (Gen_Id)); 15668 end if; 15669 end Save_Global_Defaults; 15670 15671 ---------------------------- 15672 -- Save_Global_Descendant -- 15673 ---------------------------- 15674 15675 procedure Save_Global_Descendant (D : Union_Id) is 15676 N1 : Node_Id; 15677 15678 begin 15679 if D in Node_Range then 15680 if D = Union_Id (Empty) then 15681 null; 15682 15683 elsif Nkind (Node_Id (D)) /= N_Compilation_Unit then 15684 Save_References (Node_Id (D)); 15685 end if; 15686 15687 elsif D in List_Range then 15688 pragma Assert (D /= Union_Id (No_List)); 15689 -- Because No_List = Empty, which is in Node_Range above 15690 15691 if Is_Empty_List (List_Id (D)) then 15692 null; 15693 15694 else 15695 N1 := First (List_Id (D)); 15696 while Present (N1) loop 15697 Save_References (N1); 15698 Next (N1); 15699 end loop; 15700 end if; 15701 15702 -- Element list or other non-node field, nothing to do 15703 15704 else 15705 null; 15706 end if; 15707 end Save_Global_Descendant; 15708 15709 --------------------- 15710 -- Save_References -- 15711 --------------------- 15712 15713 -- This is the recursive procedure that does the work once the enclosing 15714 -- generic scope has been established. We have to treat specially a 15715 -- number of node rewritings that are required by semantic processing 15716 -- and which change the kind of nodes in the generic copy: typically 15717 -- constant-folding, replacing an operator node by a string literal, or 15718 -- a selected component by an expanded name. In each of those cases, the 15719 -- transformation is propagated to the generic unit. 15720 15721 procedure Save_References (N : Node_Id) is 15722 Loc : constant Source_Ptr := Sloc (N); 15723 15724 function Requires_Delayed_Save (Nod : Node_Id) return Boolean; 15725 -- Determine whether arbitrary node Nod requires delayed capture of 15726 -- global references within its aspect specifications. 15727 15728 procedure Save_References_In_Aggregate (N : Node_Id); 15729 -- Save all global references in [extension] aggregate node N 15730 15731 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id); 15732 -- Save all global references in a character literal or operator 15733 -- symbol denoted by N. 15734 15735 procedure Save_References_In_Descendants (N : Node_Id); 15736 -- Save all global references in all descendants of node N 15737 15738 procedure Save_References_In_Identifier (N : Node_Id); 15739 -- Save all global references in identifier node N 15740 15741 procedure Save_References_In_Operator (N : Node_Id); 15742 -- Save all global references in operator node N 15743 15744 procedure Save_References_In_Pragma (Prag : Node_Id); 15745 -- Save all global references found within the expression of pragma 15746 -- Prag. 15747 15748 --------------------------- 15749 -- Requires_Delayed_Save -- 15750 --------------------------- 15751 15752 function Requires_Delayed_Save (Nod : Node_Id) return Boolean is 15753 begin 15754 -- Generic packages and subprograms require delayed capture of 15755 -- global references within their aspects due to the timing of 15756 -- annotation analysis. 15757 15758 if Nkind_In (Nod, N_Generic_Package_Declaration, 15759 N_Generic_Subprogram_Declaration, 15760 N_Package_Body, 15761 N_Package_Body_Stub, 15762 N_Subprogram_Body, 15763 N_Subprogram_Body_Stub) 15764 then 15765 -- Since the capture of global references is done on the 15766 -- unanalyzed generic template, there is no information around 15767 -- to infer the context. Use the Associated_Entity linkages to 15768 -- peek into the analyzed generic copy and determine what the 15769 -- template corresponds to. 15770 15771 if Nod = Templ then 15772 return 15773 Is_Generic_Declaration_Or_Body 15774 (Unit_Declaration_Node 15775 (Associated_Entity (Defining_Entity (Nod)))); 15776 15777 -- Otherwise the generic unit being processed is not the top 15778 -- level template. It is safe to capture of global references 15779 -- within the generic unit because at this point the top level 15780 -- copy is fully analyzed. 15781 15782 else 15783 return False; 15784 end if; 15785 15786 -- Otherwise capture the global references without interference 15787 15788 else 15789 return False; 15790 end if; 15791 end Requires_Delayed_Save; 15792 15793 ---------------------------------- 15794 -- Save_References_In_Aggregate -- 15795 ---------------------------------- 15796 15797 procedure Save_References_In_Aggregate (N : Node_Id) is 15798 Nam : Node_Id; 15799 Qual : Node_Id := Empty; 15800 Typ : Entity_Id := Empty; 15801 15802 use Atree.Unchecked_Access; 15803 -- This code section is part of implementing an untyped tree 15804 -- traversal, so it needs direct access to node fields. 15805 15806 begin 15807 N2 := Get_Associated_Node (N); 15808 15809 if Present (N2) then 15810 Typ := Etype (N2); 15811 15812 -- In an instance within a generic, use the name of the actual 15813 -- and not the original generic parameter. If the actual is 15814 -- global in the current generic it must be preserved for its 15815 -- instantiation. 15816 15817 if Nkind (Parent (Typ)) = N_Subtype_Declaration 15818 and then Present (Generic_Parent_Type (Parent (Typ))) 15819 then 15820 Typ := Base_Type (Typ); 15821 Set_Etype (N2, Typ); 15822 end if; 15823 end if; 15824 15825 if No (N2) or else No (Typ) or else not Is_Global (Typ) then 15826 Set_Associated_Node (N, Empty); 15827 15828 -- If the aggregate is an actual in a call, it has been 15829 -- resolved in the current context, to some local type. The 15830 -- enclosing call may have been disambiguated by the aggregate, 15831 -- and this disambiguation might fail at instantiation time 15832 -- because the type to which the aggregate did resolve is not 15833 -- preserved. In order to preserve some of this information, 15834 -- wrap the aggregate in a qualified expression, using the id 15835 -- of its type. For further disambiguation we qualify the type 15836 -- name with its scope (if visible and not hidden by a local 15837 -- homograph) because both id's will have corresponding 15838 -- entities in an instance. This resolves most of the problems 15839 -- with missing type information on aggregates in instances. 15840 15841 if Present (N2) 15842 and then Nkind (N2) = Nkind (N) 15843 and then Nkind (Parent (N2)) in N_Subprogram_Call 15844 and then Present (Typ) 15845 and then Comes_From_Source (Typ) 15846 then 15847 Nam := Make_Identifier (Loc, Chars (Typ)); 15848 15849 if Is_Immediately_Visible (Scope (Typ)) 15850 and then 15851 (not In_Open_Scopes (Scope (Typ)) 15852 or else Current_Entity (Scope (Typ)) = Scope (Typ)) 15853 then 15854 Nam := 15855 Make_Selected_Component (Loc, 15856 Prefix => 15857 Make_Identifier (Loc, Chars (Scope (Typ))), 15858 Selector_Name => Nam); 15859 end if; 15860 15861 Qual := 15862 Make_Qualified_Expression (Loc, 15863 Subtype_Mark => Nam, 15864 Expression => Relocate_Node (N)); 15865 end if; 15866 end if; 15867 15868 Save_Global_Descendant (Field1 (N)); 15869 Save_Global_Descendant (Field2 (N)); 15870 Save_Global_Descendant (Field3 (N)); 15871 Save_Global_Descendant (Field5 (N)); 15872 15873 if Present (Qual) then 15874 Rewrite (N, Qual); 15875 end if; 15876 end Save_References_In_Aggregate; 15877 15878 ---------------------------------------------- 15879 -- Save_References_In_Char_Lit_Or_Op_Symbol -- 15880 ---------------------------------------------- 15881 15882 procedure Save_References_In_Char_Lit_Or_Op_Symbol (N : Node_Id) is 15883 begin 15884 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15885 Reset_Entity (N); 15886 15887 elsif Nkind (N) = N_Operator_Symbol 15888 and then Nkind (Get_Associated_Node (N)) = N_String_Literal 15889 then 15890 Change_Operator_Symbol_To_String_Literal (N); 15891 end if; 15892 end Save_References_In_Char_Lit_Or_Op_Symbol; 15893 15894 ------------------------------------ 15895 -- Save_References_In_Descendants -- 15896 ------------------------------------ 15897 15898 procedure Save_References_In_Descendants (N : Node_Id) is 15899 use Atree.Unchecked_Access; 15900 -- This code section is part of implementing an untyped tree 15901 -- traversal, so it needs direct access to node fields. 15902 15903 begin 15904 Save_Global_Descendant (Field1 (N)); 15905 Save_Global_Descendant (Field2 (N)); 15906 Save_Global_Descendant (Field3 (N)); 15907 Save_Global_Descendant (Field4 (N)); 15908 Save_Global_Descendant (Field5 (N)); 15909 end Save_References_In_Descendants; 15910 15911 ----------------------------------- 15912 -- Save_References_In_Identifier -- 15913 ----------------------------------- 15914 15915 procedure Save_References_In_Identifier (N : Node_Id) is 15916 begin 15917 -- The node did not undergo a transformation 15918 15919 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 15920 declare 15921 Aux_N2 : constant Node_Id := Get_Associated_Node (N); 15922 Orig_N2_Parent : constant Node_Id := 15923 Original_Node (Parent (Aux_N2)); 15924 begin 15925 -- The parent of this identifier is a selected component 15926 -- which denotes a named number that was constant folded. 15927 -- Preserve the original name for ASIS and link the parent 15928 -- with its expanded name. The constant folding will be 15929 -- repeated in the instance. 15930 15931 if Nkind (Parent (N)) = N_Selected_Component 15932 and then Nkind_In (Parent (Aux_N2), N_Integer_Literal, 15933 N_Real_Literal) 15934 and then Is_Entity_Name (Orig_N2_Parent) 15935 and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind 15936 and then Is_Global (Entity (Orig_N2_Parent)) 15937 then 15938 N2 := Aux_N2; 15939 Set_Associated_Node 15940 (Parent (N), Original_Node (Parent (N2))); 15941 15942 -- Common case 15943 15944 else 15945 -- If this is a discriminant reference, always save it. 15946 -- It is used in the instance to find the corresponding 15947 -- discriminant positionally rather than by name. 15948 15949 Set_Original_Discriminant 15950 (N, Original_Discriminant (Get_Associated_Node (N))); 15951 end if; 15952 15953 Reset_Entity (N); 15954 end; 15955 15956 -- The analysis of the generic copy transformed the identifier 15957 -- into another construct. Propagate the changes to the template. 15958 15959 else 15960 N2 := Get_Associated_Node (N); 15961 15962 -- The identifier denotes a call to a parameterless function. 15963 -- Mark the node as resolved when the function is external. 15964 15965 if Nkind (N2) = N_Function_Call then 15966 E := Entity (Name (N2)); 15967 15968 if Present (E) and then Is_Global (E) then 15969 Set_Etype (N, Etype (N2)); 15970 else 15971 Set_Associated_Node (N, Empty); 15972 Set_Etype (N, Empty); 15973 end if; 15974 15975 -- The identifier denotes a named number that was constant 15976 -- folded. Preserve the original name for ASIS and undo the 15977 -- constant folding which will be repeated in the instance. 15978 15979 elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal) 15980 and then Is_Entity_Name (Original_Node (N2)) 15981 then 15982 Set_Associated_Node (N, Original_Node (N2)); 15983 Reset_Entity (N); 15984 15985 -- The identifier resolved to a string literal. Propagate this 15986 -- information to the generic template. 15987 15988 elsif Nkind (N2) = N_String_Literal then 15989 Rewrite (N, New_Copy (N2)); 15990 15991 -- The identifier is rewritten as a dereference if it is the 15992 -- prefix of an implicit dereference. Preserve the original 15993 -- tree as the analysis of the instance will expand the node 15994 -- again, but preserve the resolved entity if it is global. 15995 15996 elsif Nkind (N2) = N_Explicit_Dereference then 15997 if Is_Entity_Name (Prefix (N2)) 15998 and then Present (Entity (Prefix (N2))) 15999 and then Is_Global (Entity (Prefix (N2))) 16000 then 16001 Set_Associated_Node (N, Prefix (N2)); 16002 16003 elsif Nkind (Prefix (N2)) = N_Function_Call 16004 and then Present (Entity (Name (Prefix (N2)))) 16005 and then Is_Global (Entity (Name (Prefix (N2)))) 16006 then 16007 Rewrite (N, 16008 Make_Explicit_Dereference (Loc, 16009 Prefix => 16010 Make_Function_Call (Loc, 16011 Name => 16012 New_Occurrence_Of 16013 (Entity (Name (Prefix (N2))), Loc)))); 16014 16015 else 16016 Set_Associated_Node (N, Empty); 16017 Set_Etype (N, Empty); 16018 end if; 16019 16020 -- The subtype mark of a nominally unconstrained object is 16021 -- rewritten as a subtype indication using the bounds of the 16022 -- expression. Recover the original subtype mark. 16023 16024 elsif Nkind (N2) = N_Subtype_Indication 16025 and then Is_Entity_Name (Original_Node (N2)) 16026 then 16027 Set_Associated_Node (N, Original_Node (N2)); 16028 Reset_Entity (N); 16029 end if; 16030 end if; 16031 end Save_References_In_Identifier; 16032 16033 --------------------------------- 16034 -- Save_References_In_Operator -- 16035 --------------------------------- 16036 16037 procedure Save_References_In_Operator (N : Node_Id) is 16038 begin 16039 -- The node did not undergo a transformation 16040 16041 if Nkind (N) = Nkind (Get_Associated_Node (N)) then 16042 if Nkind (N) = N_Op_Concat then 16043 Set_Is_Component_Left_Opnd (N, 16044 Is_Component_Left_Opnd (Get_Associated_Node (N))); 16045 16046 Set_Is_Component_Right_Opnd (N, 16047 Is_Component_Right_Opnd (Get_Associated_Node (N))); 16048 end if; 16049 16050 Reset_Entity (N); 16051 16052 -- The analysis of the generic copy transformed the operator into 16053 -- some other construct. Propagate the changes to the template if 16054 -- applicable. 16055 16056 else 16057 N2 := Get_Associated_Node (N); 16058 16059 -- The operator resoved to a function call 16060 16061 if Nkind (N2) = N_Function_Call then 16062 16063 -- Add explicit qualifications in the generic template for 16064 -- all operands of universal type. This aids resolution by 16065 -- preserving the actual type of a literal or an attribute 16066 -- that yields a universal result. 16067 16068 Qualify_Universal_Operands (N, N2); 16069 16070 E := Entity (Name (N2)); 16071 16072 if Present (E) and then Is_Global (E) then 16073 Set_Etype (N, Etype (N2)); 16074 else 16075 Set_Associated_Node (N, Empty); 16076 Set_Etype (N, Empty); 16077 end if; 16078 16079 -- The operator was folded into a literal 16080 16081 elsif Nkind_In (N2, N_Integer_Literal, 16082 N_Real_Literal, 16083 N_String_Literal) 16084 then 16085 if Present (Original_Node (N2)) 16086 and then Nkind (Original_Node (N2)) = Nkind (N) 16087 then 16088 -- Operation was constant-folded. Whenever possible, 16089 -- recover semantic information from unfolded node, 16090 -- for ASIS use. 16091 16092 Set_Associated_Node (N, Original_Node (N2)); 16093 16094 if Nkind (N) = N_Op_Concat then 16095 Set_Is_Component_Left_Opnd (N, 16096 Is_Component_Left_Opnd (Get_Associated_Node (N))); 16097 Set_Is_Component_Right_Opnd (N, 16098 Is_Component_Right_Opnd (Get_Associated_Node (N))); 16099 end if; 16100 16101 Reset_Entity (N); 16102 16103 -- Propagate the constant folding back to the template 16104 16105 else 16106 Rewrite (N, New_Copy (N2)); 16107 Set_Analyzed (N, False); 16108 end if; 16109 16110 -- The operator was folded into an enumeration literal. Retain 16111 -- the entity to avoid spurious ambiguities if it is overloaded 16112 -- at the point of instantiation or inlining. 16113 16114 elsif Nkind (N2) = N_Identifier 16115 and then Ekind (Entity (N2)) = E_Enumeration_Literal 16116 then 16117 Rewrite (N, New_Copy (N2)); 16118 Set_Analyzed (N, False); 16119 end if; 16120 end if; 16121 16122 -- Complete the operands check if node has not been constant 16123 -- folded. 16124 16125 if Nkind (N) in N_Op then 16126 Save_Entity_Descendants (N); 16127 end if; 16128 end Save_References_In_Operator; 16129 16130 ------------------------------- 16131 -- Save_References_In_Pragma -- 16132 ------------------------------- 16133 16134 procedure Save_References_In_Pragma (Prag : Node_Id) is 16135 Context : Node_Id; 16136 Do_Save : Boolean := True; 16137 16138 use Atree.Unchecked_Access; 16139 -- This code section is part of implementing an untyped tree 16140 -- traversal, so it needs direct access to node fields. 16141 16142 begin 16143 -- Do not save global references in pragmas generated from aspects 16144 -- because the pragmas will be regenerated at instantiation time. 16145 16146 if From_Aspect_Specification (Prag) then 16147 Do_Save := False; 16148 16149 -- The capture of global references within contract-related source 16150 -- pragmas associated with generic packages, subprograms or their 16151 -- respective bodies must be delayed due to timing of annotation 16152 -- analysis. Global references are still captured in routine 16153 -- Save_Global_References_In_Contract. 16154 16155 elsif Is_Generic_Contract_Pragma (Prag) and then Prag /= Templ then 16156 if Is_Package_Contract_Annotation (Prag) then 16157 Context := Find_Related_Package_Or_Body (Prag); 16158 else 16159 pragma Assert (Is_Subprogram_Contract_Annotation (Prag)); 16160 Context := Find_Related_Declaration_Or_Body (Prag); 16161 end if; 16162 16163 -- The use of Original_Node accounts for the case when the 16164 -- related context is generic template. 16165 16166 if Requires_Delayed_Save (Original_Node (Context)) then 16167 Do_Save := False; 16168 end if; 16169 end if; 16170 16171 -- For all other cases, save all global references within the 16172 -- descendants, but skip the following semantic fields: 16173 16174 -- Field1 - Next_Pragma 16175 -- Field3 - Corresponding_Aspect 16176 -- Field5 - Next_Rep_Item 16177 16178 if Do_Save then 16179 Save_Global_Descendant (Field2 (Prag)); 16180 Save_Global_Descendant (Field4 (Prag)); 16181 end if; 16182 end Save_References_In_Pragma; 16183 16184 -- Start of processing for Save_References 16185 16186 begin 16187 if N = Empty then 16188 null; 16189 16190 -- Aggregates 16191 16192 elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then 16193 Save_References_In_Aggregate (N); 16194 16195 -- Character literals, operator symbols 16196 16197 elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then 16198 Save_References_In_Char_Lit_Or_Op_Symbol (N); 16199 16200 -- Defining identifiers 16201 16202 elsif Nkind (N) in N_Entity then 16203 null; 16204 16205 -- Identifiers 16206 16207 elsif Nkind (N) = N_Identifier then 16208 Save_References_In_Identifier (N); 16209 16210 -- Operators 16211 16212 elsif Nkind (N) in N_Op then 16213 Save_References_In_Operator (N); 16214 16215 -- Pragmas 16216 16217 elsif Nkind (N) = N_Pragma then 16218 Save_References_In_Pragma (N); 16219 16220 else 16221 Save_References_In_Descendants (N); 16222 end if; 16223 16224 -- Save all global references found within the aspect specifications 16225 -- of the related node. 16226 16227 if Permits_Aspect_Specifications (N) and then Has_Aspects (N) then 16228 16229 -- The capture of global references within aspects associated with 16230 -- generic packages, subprograms or their bodies must be delayed 16231 -- due to timing of annotation analysis. Global references are 16232 -- still captured in routine Save_Global_References_In_Contract. 16233 16234 if Requires_Delayed_Save (N) then 16235 null; 16236 16237 -- Otherwise save all global references within the aspects 16238 16239 else 16240 Save_Global_References_In_Aspects (N); 16241 end if; 16242 end if; 16243 end Save_References; 16244 16245 -- Start of processing for Save_Global_References 16246 16247 begin 16248 Gen_Scope := Current_Scope; 16249 16250 -- If the generic unit is a child unit, references to entities in the 16251 -- parent are treated as local, because they will be resolved anew in 16252 -- the context of the instance of the parent. 16253 16254 while Is_Child_Unit (Gen_Scope) 16255 and then Ekind (Scope (Gen_Scope)) = E_Generic_Package 16256 loop 16257 Gen_Scope := Scope (Gen_Scope); 16258 end loop; 16259 16260 Save_References (Templ); 16261 end Save_Global_References; 16262 16263 --------------------------------------- 16264 -- Save_Global_References_In_Aspects -- 16265 --------------------------------------- 16266 16267 procedure Save_Global_References_In_Aspects (N : Node_Id) is 16268 Asp : Node_Id; 16269 Expr : Node_Id; 16270 16271 begin 16272 Asp := First (Aspect_Specifications (N)); 16273 while Present (Asp) loop 16274 Expr := Expression (Asp); 16275 16276 if Present (Expr) then 16277 Save_Global_References (Expr); 16278 end if; 16279 16280 Next (Asp); 16281 end loop; 16282 end Save_Global_References_In_Aspects; 16283 16284 ------------------------------------------ 16285 -- Set_Copied_Sloc_For_Inherited_Pragma -- 16286 ------------------------------------------ 16287 16288 procedure Set_Copied_Sloc_For_Inherited_Pragma 16289 (N : Node_Id; 16290 E : Entity_Id) 16291 is 16292 begin 16293 Create_Instantiation_Source (N, E, 16294 Inlined_Body => False, 16295 Inherited_Pragma => True, 16296 Factor => S_Adjustment); 16297 end Set_Copied_Sloc_For_Inherited_Pragma; 16298 16299 -------------------------------------- 16300 -- Set_Copied_Sloc_For_Inlined_Body -- 16301 -------------------------------------- 16302 16303 procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is 16304 begin 16305 Create_Instantiation_Source (N, E, 16306 Inlined_Body => True, 16307 Inherited_Pragma => False, 16308 Factor => S_Adjustment); 16309 end Set_Copied_Sloc_For_Inlined_Body; 16310 16311 --------------------- 16312 -- Set_Instance_Of -- 16313 --------------------- 16314 16315 procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id) is 16316 begin 16317 Generic_Renamings.Table (Generic_Renamings.Last) := (A, B, Assoc_Null); 16318 Generic_Renamings_HTable.Set (Generic_Renamings.Last); 16319 Generic_Renamings.Increment_Last; 16320 end Set_Instance_Of; 16321 16322 -------------------- 16323 -- Set_Next_Assoc -- 16324 -------------------- 16325 16326 procedure Set_Next_Assoc (E : Assoc_Ptr; Next : Assoc_Ptr) is 16327 begin 16328 Generic_Renamings.Table (E).Next_In_HTable := Next; 16329 end Set_Next_Assoc; 16330 16331 ------------------- 16332 -- Start_Generic -- 16333 ------------------- 16334 16335 procedure Start_Generic is 16336 begin 16337 -- ??? More things could be factored out in this routine. 16338 -- Should probably be done at a later stage. 16339 16340 Generic_Flags.Append (Inside_A_Generic); 16341 Inside_A_Generic := True; 16342 16343 Expander_Mode_Save_And_Set (False); 16344 end Start_Generic; 16345 16346 ---------------------- 16347 -- Set_Instance_Env -- 16348 ---------------------- 16349 16350 -- WARNING: This routine manages SPARK regions 16351 16352 procedure Set_Instance_Env 16353 (Gen_Unit : Entity_Id; 16354 Act_Unit : Entity_Id) 16355 is 16356 Saved_AE : constant Boolean := Assertions_Enabled; 16357 Saved_CPL : constant Node_Id := Check_Policy_List; 16358 Saved_DEC : constant Boolean := Dynamic_Elaboration_Checks; 16359 Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; 16360 Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; 16361 16362 begin 16363 -- Regardless of the current mode, predefined units are analyzed in the 16364 -- most current Ada mode, and earlier version Ada checks do not apply 16365 -- to predefined units. Nothing needs to be done for non-internal units. 16366 -- These are always analyzed in the current mode. 16367 16368 if In_Internal_Unit (Gen_Unit) then 16369 16370 -- The following call resets all configuration attributes to default 16371 -- or the xxx_Config versions of the attributes when the current sem 16372 -- unit is the main unit. At the same time, internal units must also 16373 -- inherit certain configuration attributes from their context. It 16374 -- is unclear what these two sets are. 16375 16376 Set_Config_Switches (True, Current_Sem_Unit = Main_Unit); 16377 16378 -- Reinstall relevant configuration attributes of the context 16379 16380 Assertions_Enabled := Saved_AE; 16381 Check_Policy_List := Saved_CPL; 16382 Dynamic_Elaboration_Checks := Saved_DEC; 16383 16384 Install_SPARK_Mode (Saved_SM, Saved_SMP); 16385 end if; 16386 16387 Current_Instantiated_Parent := 16388 (Gen_Id => Gen_Unit, 16389 Act_Id => Act_Unit, 16390 Next_In_HTable => Assoc_Null); 16391 end Set_Instance_Env; 16392 16393 ----------------- 16394 -- Switch_View -- 16395 ----------------- 16396 16397 procedure Switch_View (T : Entity_Id) is 16398 BT : constant Entity_Id := Base_Type (T); 16399 Priv_Elmt : Elmt_Id := No_Elmt; 16400 Priv_Sub : Entity_Id; 16401 16402 begin 16403 -- T may be private but its base type may have been exchanged through 16404 -- some other occurrence, in which case there is nothing to switch 16405 -- besides T itself. Note that a private dependent subtype of a private 16406 -- type might not have been switched even if the base type has been, 16407 -- because of the last branch of Check_Private_View (see comment there). 16408 16409 if not Is_Private_Type (BT) then 16410 Prepend_Elmt (Full_View (T), Exchanged_Views); 16411 Exchange_Declarations (T); 16412 return; 16413 end if; 16414 16415 Priv_Elmt := First_Elmt (Private_Dependents (BT)); 16416 16417 if Present (Full_View (BT)) then 16418 Prepend_Elmt (Full_View (BT), Exchanged_Views); 16419 Exchange_Declarations (BT); 16420 end if; 16421 16422 while Present (Priv_Elmt) loop 16423 Priv_Sub := (Node (Priv_Elmt)); 16424 16425 -- We avoid flipping the subtype if the Etype of its full view is 16426 -- private because this would result in a malformed subtype. This 16427 -- occurs when the Etype of the subtype full view is the full view of 16428 -- the base type (and since the base types were just switched, the 16429 -- subtype is pointing to the wrong view). This is currently the case 16430 -- for tagged record types, access types (maybe more?) and needs to 16431 -- be resolved. ??? 16432 16433 if Present (Full_View (Priv_Sub)) 16434 and then not Is_Private_Type (Etype (Full_View (Priv_Sub))) 16435 then 16436 Prepend_Elmt (Full_View (Priv_Sub), Exchanged_Views); 16437 Exchange_Declarations (Priv_Sub); 16438 end if; 16439 16440 Next_Elmt (Priv_Elmt); 16441 end loop; 16442 end Switch_View; 16443 16444 ----------------- 16445 -- True_Parent -- 16446 ----------------- 16447 16448 function True_Parent (N : Node_Id) return Node_Id is 16449 begin 16450 if Nkind (Parent (N)) = N_Subunit then 16451 return Parent (Corresponding_Stub (Parent (N))); 16452 else 16453 return Parent (N); 16454 end if; 16455 end True_Parent; 16456 16457 ----------------------------- 16458 -- Valid_Default_Attribute -- 16459 ----------------------------- 16460 16461 procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is 16462 Attr_Id : constant Attribute_Id := 16463 Get_Attribute_Id (Attribute_Name (Def)); 16464 T : constant Entity_Id := Entity (Prefix (Def)); 16465 Is_Fun : constant Boolean := (Ekind (Nam) = E_Function); 16466 F : Entity_Id; 16467 Num_F : Nat; 16468 OK : Boolean; 16469 16470 begin 16471 if No (T) or else T = Any_Id then 16472 return; 16473 end if; 16474 16475 Num_F := 0; 16476 F := First_Formal (Nam); 16477 while Present (F) loop 16478 Num_F := Num_F + 1; 16479 Next_Formal (F); 16480 end loop; 16481 16482 case Attr_Id is 16483 when Attribute_Adjacent 16484 | Attribute_Ceiling 16485 | Attribute_Copy_Sign 16486 | Attribute_Floor 16487 | Attribute_Fraction 16488 | Attribute_Machine 16489 | Attribute_Model 16490 | Attribute_Remainder 16491 | Attribute_Rounding 16492 | Attribute_Unbiased_Rounding 16493 => 16494 OK := Is_Fun 16495 and then Num_F = 1 16496 and then Is_Floating_Point_Type (T); 16497 16498 when Attribute_Image 16499 | Attribute_Pred 16500 | Attribute_Succ 16501 | Attribute_Value 16502 | Attribute_Wide_Image 16503 | Attribute_Wide_Value 16504 => 16505 OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T); 16506 16507 when Attribute_Max 16508 | Attribute_Min 16509 => 16510 OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T); 16511 16512 when Attribute_Input => 16513 OK := (Is_Fun and then Num_F = 1); 16514 16515 when Attribute_Output 16516 | Attribute_Read 16517 | Attribute_Write 16518 => 16519 OK := not Is_Fun and then Num_F = 2; 16520 16521 when others => 16522 OK := False; 16523 end case; 16524 16525 if not OK then 16526 Error_Msg_N 16527 ("attribute reference has wrong profile for subprogram", Def); 16528 end if; 16529 end Valid_Default_Attribute; 16530 16531end Sem_Ch12; 16532