1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 8 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Errout; use Errout; 31with Exp_Disp; use Exp_Disp; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Freeze; use Freeze; 35with Ghost; use Ghost; 36with Impunit; use Impunit; 37with Lib; use Lib; 38with Lib.Load; use Lib.Load; 39with Lib.Xref; use Lib.Xref; 40with Namet; use Namet; 41with Namet.Sp; use Namet.Sp; 42with Nlists; use Nlists; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Output; use Output; 46with Restrict; use Restrict; 47with Rident; use Rident; 48with Rtsfind; use Rtsfind; 49with Sem; use Sem; 50with Sem_Aux; use Sem_Aux; 51with Sem_Cat; use Sem_Cat; 52with Sem_Ch3; use Sem_Ch3; 53with Sem_Ch4; use Sem_Ch4; 54with Sem_Ch6; use Sem_Ch6; 55with Sem_Ch12; use Sem_Ch12; 56with Sem_Ch13; use Sem_Ch13; 57with Sem_Dim; use Sem_Dim; 58with Sem_Disp; use Sem_Disp; 59with Sem_Dist; use Sem_Dist; 60with Sem_Elab; use Sem_Elab; 61with Sem_Eval; use Sem_Eval; 62with Sem_Prag; use Sem_Prag; 63with Sem_Res; use Sem_Res; 64with Sem_Util; use Sem_Util; 65with Sem_Type; use Sem_Type; 66with Stand; use Stand; 67with Sinfo; use Sinfo; 68with Sinfo.CN; use Sinfo.CN; 69with Snames; use Snames; 70with Style; 71with Table; 72with Tbuild; use Tbuild; 73with Uintp; use Uintp; 74 75package body Sem_Ch8 is 76 77 ------------------------------------ 78 -- Visibility and Name Resolution -- 79 ------------------------------------ 80 81 -- This package handles name resolution and the collection of possible 82 -- interpretations for overloaded names, prior to overload resolution. 83 84 -- Name resolution is the process that establishes a mapping between source 85 -- identifiers and the entities they denote at each point in the program. 86 -- Each entity is represented by a defining occurrence. Each identifier 87 -- that denotes an entity points to the corresponding defining occurrence. 88 -- This is the entity of the applied occurrence. Each occurrence holds 89 -- an index into the names table, where source identifiers are stored. 90 91 -- Each entry in the names table for an identifier or designator uses the 92 -- Info pointer to hold a link to the currently visible entity that has 93 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id 94 -- in package Sem_Util). The visibility is initialized at the beginning of 95 -- semantic processing to make entities in package Standard immediately 96 -- visible. The visibility table is used in a more subtle way when 97 -- compiling subunits (see below). 98 99 -- Entities that have the same name (i.e. homonyms) are chained. In the 100 -- case of overloaded entities, this chain holds all the possible meanings 101 -- of a given identifier. The process of overload resolution uses type 102 -- information to select from this chain the unique meaning of a given 103 -- identifier. 104 105 -- Entities are also chained in their scope, through the Next_Entity link. 106 -- As a consequence, the name space is organized as a sparse matrix, where 107 -- each row corresponds to a scope, and each column to a source identifier. 108 -- Open scopes, that is to say scopes currently being compiled, have their 109 -- corresponding rows of entities in order, innermost scope first. 110 111 -- The scopes of packages that are mentioned in context clauses appear in 112 -- no particular order, interspersed among open scopes. This is because 113 -- in the course of analyzing the context of a compilation, a package 114 -- declaration is first an open scope, and subsequently an element of the 115 -- context. If subunits or child units are present, a parent unit may 116 -- appear under various guises at various times in the compilation. 117 118 -- When the compilation of the innermost scope is complete, the entities 119 -- defined therein are no longer visible. If the scope is not a package 120 -- declaration, these entities are never visible subsequently, and can be 121 -- removed from visibility chains. If the scope is a package declaration, 122 -- its visible declarations may still be accessible. Therefore the entities 123 -- defined in such a scope are left on the visibility chains, and only 124 -- their visibility (immediately visibility or potential use-visibility) 125 -- is affected. 126 127 -- The ordering of homonyms on their chain does not necessarily follow 128 -- the order of their corresponding scopes on the scope stack. For 129 -- example, if package P and the enclosing scope both contain entities 130 -- named E, then when compiling the package body the chain for E will 131 -- hold the global entity first, and the local one (corresponding to 132 -- the current inner scope) next. As a result, name resolution routines 133 -- do not assume any relative ordering of the homonym chains, either 134 -- for scope nesting or to order of appearance of context clauses. 135 136 -- When compiling a child unit, entities in the parent scope are always 137 -- immediately visible. When compiling the body of a child unit, private 138 -- entities in the parent must also be made immediately visible. There 139 -- are separate routines to make the visible and private declarations 140 -- visible at various times (see package Sem_Ch7). 141 142 -- +--------+ +-----+ 143 -- | In use |-------->| EU1 |--------------------------> 144 -- +--------+ +-----+ 145 -- | | 146 -- +--------+ +-----+ +-----+ 147 -- | Stand. |---------------->| ES1 |--------------->| ES2 |---> 148 -- +--------+ +-----+ +-----+ 149 -- | | 150 -- +---------+ | +-----+ 151 -- | with'ed |------------------------------>| EW2 |---> 152 -- +---------+ | +-----+ 153 -- | | 154 -- +--------+ +-----+ +-----+ 155 -- | Scope2 |---------------->| E12 |--------------->| E22 |---> 156 -- +--------+ +-----+ +-----+ 157 -- | | 158 -- +--------+ +-----+ +-----+ 159 -- | Scope1 |---------------->| E11 |--------------->| E12 |---> 160 -- +--------+ +-----+ +-----+ 161 -- ^ | | 162 -- | | | 163 -- | +---------+ | | 164 -- | | with'ed |-----------------------------------------> 165 -- | +---------+ | | 166 -- | | | 167 -- Scope stack | | 168 -- (innermost first) | | 169 -- +----------------------------+ 170 -- Names table => | Id1 | | | | Id2 | 171 -- +----------------------------+ 172 173 -- Name resolution must deal with several syntactic forms: simple names, 174 -- qualified names, indexed names, and various forms of calls. 175 176 -- Each identifier points to an entry in the names table. The resolution 177 -- of a simple name consists in traversing the homonym chain, starting 178 -- from the names table. If an entry is immediately visible, it is the one 179 -- designated by the identifier. If only potentially use-visible entities 180 -- are on the chain, we must verify that they do not hide each other. If 181 -- the entity we find is overloadable, we collect all other overloadable 182 -- entities on the chain as long as they are not hidden. 183 -- 184 -- To resolve expanded names, we must find the entity at the intersection 185 -- of the entity chain for the scope (the prefix) and the homonym chain 186 -- for the selector. In general, homonym chains will be much shorter than 187 -- entity chains, so it is preferable to start from the names table as 188 -- well. If the entity found is overloadable, we must collect all other 189 -- interpretations that are defined in the scope denoted by the prefix. 190 191 -- For records, protected types, and tasks, their local entities are 192 -- removed from visibility chains on exit from the corresponding scope. 193 -- From the outside, these entities are always accessed by selected 194 -- notation, and the entity chain for the record type, protected type, 195 -- etc. is traversed sequentially in order to find the designated entity. 196 197 -- The discriminants of a type and the operations of a protected type or 198 -- task are unchained on exit from the first view of the type, (such as 199 -- a private or incomplete type declaration, or a protected type speci- 200 -- fication) and re-chained when compiling the second view. 201 202 -- In the case of operators, we do not make operators on derived types 203 -- explicit. As a result, the notation P."+" may denote either a user- 204 -- defined function with name "+", or else an implicit declaration of the 205 -- operator "+" in package P. The resolution of expanded names always 206 -- tries to resolve an operator name as such an implicitly defined entity, 207 -- in addition to looking for explicit declarations. 208 209 -- All forms of names that denote entities (simple names, expanded names, 210 -- character literals in some cases) have a Entity attribute, which 211 -- identifies the entity denoted by the name. 212 213 --------------------- 214 -- The Scope Stack -- 215 --------------------- 216 217 -- The Scope stack keeps track of the scopes currently been compiled. 218 -- Every entity that contains declarations (including records) is placed 219 -- on the scope stack while it is being processed, and removed at the end. 220 -- Whenever a non-package scope is exited, the entities defined therein 221 -- are removed from the visibility table, so that entities in outer scopes 222 -- become visible (see previous description). On entry to Sem, the scope 223 -- stack only contains the package Standard. As usual, subunits complicate 224 -- this picture ever so slightly. 225 226 -- The Rtsfind mechanism can force a call to Semantics while another 227 -- compilation is in progress. The unit retrieved by Rtsfind must be 228 -- compiled in its own context, and has no access to the visibility of 229 -- the unit currently being compiled. The procedures Save_Scope_Stack and 230 -- Restore_Scope_Stack make entities in current open scopes invisible 231 -- before compiling the retrieved unit, and restore the compilation 232 -- environment afterwards. 233 234 ------------------------ 235 -- Compiling subunits -- 236 ------------------------ 237 238 -- Subunits must be compiled in the environment of the corresponding stub, 239 -- that is to say with the same visibility into the parent (and its 240 -- context) that is available at the point of the stub declaration, but 241 -- with the additional visibility provided by the context clause of the 242 -- subunit itself. As a result, compilation of a subunit forces compilation 243 -- of the parent (see description in lib-). At the point of the stub 244 -- declaration, Analyze is called recursively to compile the proper body of 245 -- the subunit, but without reinitializing the names table, nor the scope 246 -- stack (i.e. standard is not pushed on the stack). In this fashion the 247 -- context of the subunit is added to the context of the parent, and the 248 -- subunit is compiled in the correct environment. Note that in the course 249 -- of processing the context of a subunit, Standard will appear twice on 250 -- the scope stack: once for the parent of the subunit, and once for the 251 -- unit in the context clause being compiled. However, the two sets of 252 -- entities are not linked by homonym chains, so that the compilation of 253 -- any context unit happens in a fresh visibility environment. 254 255 ------------------------------- 256 -- Processing of USE Clauses -- 257 ------------------------------- 258 259 -- Every defining occurrence has a flag indicating if it is potentially use 260 -- visible. Resolution of simple names examines this flag. The processing 261 -- of use clauses consists in setting this flag on all visible entities 262 -- defined in the corresponding package. On exit from the scope of the use 263 -- clause, the corresponding flag must be reset. However, a package may 264 -- appear in several nested use clauses (pathological but legal, alas) 265 -- which forces us to use a slightly more involved scheme: 266 267 -- a) The defining occurrence for a package holds a flag -In_Use- to 268 -- indicate that it is currently in the scope of a use clause. If a 269 -- redundant use clause is encountered, then the corresponding occurrence 270 -- of the package name is flagged -Redundant_Use-. 271 272 -- b) On exit from a scope, the use clauses in its declarative part are 273 -- scanned. The visibility flag is reset in all entities declared in 274 -- package named in a use clause, as long as the package is not flagged 275 -- as being in a redundant use clause (in which case the outer use 276 -- clause is still in effect, and the direct visibility of its entities 277 -- must be retained). 278 279 -- Note that entities are not removed from their homonym chains on exit 280 -- from the package specification. A subsequent use clause does not need 281 -- to rechain the visible entities, but only to establish their direct 282 -- visibility. 283 284 ----------------------------------- 285 -- Handling private declarations -- 286 ----------------------------------- 287 288 -- The principle that each entity has a single defining occurrence clashes 289 -- with the presence of two separate definitions for private types: the 290 -- first is the private type declaration, and second is the full type 291 -- declaration. It is important that all references to the type point to 292 -- the same defining occurrence, namely the first one. To enforce the two 293 -- separate views of the entity, the corresponding information is swapped 294 -- between the two declarations. Outside of the package, the defining 295 -- occurrence only contains the private declaration information, while in 296 -- the private part and the body of the package the defining occurrence 297 -- contains the full declaration. To simplify the swap, the defining 298 -- occurrence that currently holds the private declaration points to the 299 -- full declaration. During semantic processing the defining occurrence 300 -- also points to a list of private dependents, that is to say access types 301 -- or composite types whose designated types or component types are 302 -- subtypes or derived types of the private type in question. After the 303 -- full declaration has been seen, the private dependents are updated to 304 -- indicate that they have full definitions. 305 306 ------------------------------------ 307 -- Handling of Undefined Messages -- 308 ------------------------------------ 309 310 -- In normal mode, only the first use of an undefined identifier generates 311 -- a message. The table Urefs is used to record error messages that have 312 -- been issued so that second and subsequent ones do not generate further 313 -- messages. However, the second reference causes text to be added to the 314 -- original undefined message noting "(more references follow)". The 315 -- full error list option (-gnatf) forces messages to be generated for 316 -- every reference and disconnects the use of this table. 317 318 type Uref_Entry is record 319 Node : Node_Id; 320 -- Node for identifier for which original message was posted. The 321 -- Chars field of this identifier is used to detect later references 322 -- to the same identifier. 323 324 Err : Error_Msg_Id; 325 -- Records error message Id of original undefined message. Reset to 326 -- No_Error_Msg after the second occurrence, where it is used to add 327 -- text to the original message as described above. 328 329 Nvis : Boolean; 330 -- Set if the message is not visible rather than undefined 331 332 Loc : Source_Ptr; 333 -- Records location of error message. Used to make sure that we do 334 -- not consider a, b : undefined as two separate instances, which 335 -- would otherwise happen, since the parser converts this sequence 336 -- to a : undefined; b : undefined. 337 338 end record; 339 340 package Urefs is new Table.Table ( 341 Table_Component_Type => Uref_Entry, 342 Table_Index_Type => Nat, 343 Table_Low_Bound => 1, 344 Table_Initial => 10, 345 Table_Increment => 100, 346 Table_Name => "Urefs"); 347 348 Candidate_Renaming : Entity_Id; 349 -- Holds a candidate interpretation that appears in a subprogram renaming 350 -- declaration and does not match the given specification, but matches at 351 -- least on the first formal. Allows better error message when given 352 -- specification omits defaulted parameters, a common error. 353 354 ----------------------- 355 -- Local Subprograms -- 356 ----------------------- 357 358 procedure Analyze_Generic_Renaming 359 (N : Node_Id; 360 K : Entity_Kind); 361 -- Common processing for all three kinds of generic renaming declarations. 362 -- Enter new name and indicate that it renames the generic unit. 363 364 procedure Analyze_Renamed_Character 365 (N : Node_Id; 366 New_S : Entity_Id; 367 Is_Body : Boolean); 368 -- Renamed entity is given by a character literal, which must belong 369 -- to the return type of the new entity. Is_Body indicates whether the 370 -- declaration is a renaming_as_body. If the original declaration has 371 -- already been frozen (because of an intervening body, e.g.) the body of 372 -- the function must be built now. The same applies to the following 373 -- various renaming procedures. 374 375 procedure Analyze_Renamed_Dereference 376 (N : Node_Id; 377 New_S : Entity_Id; 378 Is_Body : Boolean); 379 -- Renamed entity is given by an explicit dereference. Prefix must be a 380 -- conformant access_to_subprogram type. 381 382 procedure Analyze_Renamed_Entry 383 (N : Node_Id; 384 New_S : Entity_Id; 385 Is_Body : Boolean); 386 -- If the renamed entity in a subprogram renaming is an entry or protected 387 -- subprogram, build a body for the new entity whose only statement is a 388 -- call to the renamed entity. 389 390 procedure Analyze_Renamed_Family_Member 391 (N : Node_Id; 392 New_S : Entity_Id; 393 Is_Body : Boolean); 394 -- Used when the renamed entity is an indexed component. The prefix must 395 -- denote an entry family. 396 397 procedure Analyze_Renamed_Primitive_Operation 398 (N : Node_Id; 399 New_S : Entity_Id; 400 Is_Body : Boolean); 401 -- If the renamed entity in a subprogram renaming is a primitive operation 402 -- or a class-wide operation in prefix form, save the target object, 403 -- which must be added to the list of actuals in any subsequent call. 404 -- The renaming operation is intrinsic because the compiler must in 405 -- fact generate a wrapper for it (6.3.1 (10 1/2)). 406 407 procedure Attribute_Renaming (N : Node_Id); 408 -- Analyze renaming of attribute as subprogram. The renaming declaration N 409 -- is rewritten as a subprogram body that returns the attribute reference 410 -- applied to the formals of the function. 411 412 procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); 413 -- Set Entity, with style check if need be. For a discriminant reference, 414 -- replace by the corresponding discriminal, i.e. the parameter of the 415 -- initialization procedure that corresponds to the discriminant. 416 417 procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); 418 -- A renaming_as_body may occur after the entity of the original decla- 419 -- ration has been frozen. In that case, the body of the new entity must 420 -- be built now, because the usual mechanism of building the renamed 421 -- body at the point of freezing will not work. Subp is the subprogram 422 -- for which N provides the Renaming_As_Body. 423 424 procedure Check_In_Previous_With_Clause 425 (N : Node_Id; 426 Nam : Node_Id); 427 -- N is a use_package clause and Nam the package name, or N is a use_type 428 -- clause and Nam is the prefix of the type name. In either case, verify 429 -- that the package is visible at that point in the context: either it 430 -- appears in a previous with_clause, or because it is a fully qualified 431 -- name and the root ancestor appears in a previous with_clause. 432 433 procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id); 434 -- Verify that the entity in a renaming declaration that is a library unit 435 -- is itself a library unit and not a nested unit or subunit. Also check 436 -- that if the renaming is a child unit of a generic parent, then the 437 -- renamed unit must also be a child unit of that parent. Finally, verify 438 -- that a renamed generic unit is not an implicit child declared within 439 -- an instance of the parent. 440 441 procedure Chain_Use_Clause (N : Node_Id); 442 -- Chain use clause onto list of uses clauses headed by First_Use_Clause in 443 -- the proper scope table entry. This is usually the current scope, but it 444 -- will be an inner scope when installing the use clauses of the private 445 -- declarations of a parent unit prior to compiling the private part of a 446 -- child unit. This chain is traversed when installing/removing use clauses 447 -- when compiling a subunit or instantiating a generic body on the fly, 448 -- when it is necessary to save and restore full environments. 449 450 function Enclosing_Instance return Entity_Id; 451 -- In an instance nested within another one, several semantic checks are 452 -- unnecessary because the legality of the nested instance has been checked 453 -- in the enclosing generic unit. This applies in particular to legality 454 -- checks on actuals for formal subprograms of the inner instance, which 455 -- are checked as subprogram renamings, and may be complicated by confusion 456 -- in private/full views. This function returns the instance enclosing the 457 -- current one if there is such, else it returns Empty. 458 -- 459 -- If the renaming determines the entity for the default of a formal 460 -- subprogram nested within another instance, choose the innermost 461 -- candidate. This is because if the formal has a box, and we are within 462 -- an enclosing instance where some candidate interpretations are local 463 -- to this enclosing instance, we know that the default was properly 464 -- resolved when analyzing the generic, so we prefer the local 465 -- candidates to those that are external. This is not always the case 466 -- but is a reasonable heuristic on the use of nested generics. The 467 -- proper solution requires a full renaming model. 468 469 function Entity_Of_Unit (U : Node_Id) return Entity_Id; 470 -- Return the appropriate entity for determining which unit has a deeper 471 -- scope: the defining entity for U, unless U is a package instance, in 472 -- which case we retrieve the entity of the instance spec. 473 474 procedure Find_Expanded_Name (N : Node_Id); 475 -- The input is a selected component known to be an expanded name. Verify 476 -- legality of selector given the scope denoted by prefix, and change node 477 -- N into a expanded name with a properly set Entity field. 478 479 function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id; 480 -- Find the most previous use clause (that is, the first one to appear in 481 -- the source) by traversing the previous clause chain that exists in both 482 -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes. 483 -- ??? a better subprogram name is in order 484 485 function Find_Renamed_Entity 486 (N : Node_Id; 487 Nam : Node_Id; 488 New_S : Entity_Id; 489 Is_Actual : Boolean := False) return Entity_Id; 490 -- Find the renamed entity that corresponds to the given parameter profile 491 -- in a subprogram renaming declaration. The renamed entity may be an 492 -- operator, a subprogram, an entry, or a protected operation. Is_Actual 493 -- indicates that the renaming is the one generated for an actual subpro- 494 -- gram in an instance, for which special visibility checks apply. 495 496 function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; 497 -- Find a type derived from Character or Wide_Character in the prefix of N. 498 -- Used to resolved qualified names whose selector is a character literal. 499 500 function Has_Private_With (E : Entity_Id) return Boolean; 501 -- Ada 2005 (AI-262): Determines if the current compilation unit has a 502 -- private with on E. 503 504 function Has_Implicit_Operator (N : Node_Id) return Boolean; 505 -- N is an expanded name whose selector is an operator name (e.g. P."+"). 506 -- declarative part contains an implicit declaration of an operator if it 507 -- has a declaration of a type to which one of the predefined operators 508 -- apply. The existence of this routine is an implementation artifact. A 509 -- more straightforward but more space-consuming choice would be to make 510 -- all inherited operators explicit in the symbol table. 511 512 procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id); 513 -- A subprogram defined by a renaming declaration inherits the parameter 514 -- profile of the renamed entity. The subtypes given in the subprogram 515 -- specification are discarded and replaced with those of the renamed 516 -- subprogram, which are then used to recheck the default values. 517 518 function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; 519 -- True if it is of a task type, a protected type, or else an access to one 520 -- of these types. 521 522 function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; 523 -- Prefix is appropriate for record if it is of a record type, or an access 524 -- to such. 525 526 function Most_Descendant_Use_Clause 527 (Clause1 : Entity_Id; 528 Clause2 : Entity_Id) return Entity_Id; 529 -- Determine which use clause parameter is the most descendant in terms of 530 -- scope. 531 -- ??? a better subprogram name is in order 532 533 procedure Premature_Usage (N : Node_Id); 534 -- Diagnose usage of an entity before it is visible 535 536 procedure Use_One_Package 537 (N : Node_Id; 538 Pack_Name : Entity_Id := Empty; 539 Force : Boolean := False); 540 -- Make visible entities declared in package P potentially use-visible 541 -- in the current context. Also used in the analysis of subunits, when 542 -- re-installing use clauses of parent units. N is the use_clause that 543 -- names P (and possibly other packages). 544 545 procedure Use_One_Type 546 (Id : Node_Id; 547 Installed : Boolean := False; 548 Force : Boolean := False); 549 -- Id is the subtype mark from a use_type_clause. This procedure makes 550 -- the primitive operators of the type potentially use-visible. The 551 -- boolean flag Installed indicates that the clause is being reinstalled 552 -- after previous analysis, and primitive operations are already chained 553 -- on the Used_Operations list of the clause. 554 555 procedure Write_Info; 556 -- Write debugging information on entities declared in current scope 557 558 -------------------------------- 559 -- Analyze_Exception_Renaming -- 560 -------------------------------- 561 562 -- The language only allows a single identifier, but the tree holds an 563 -- identifier list. The parser has already issued an error message if 564 -- there is more than one element in the list. 565 566 procedure Analyze_Exception_Renaming (N : Node_Id) is 567 Id : constant Entity_Id := Defining_Entity (N); 568 Nam : constant Node_Id := Name (N); 569 570 begin 571 Check_SPARK_05_Restriction ("exception renaming is not allowed", N); 572 573 Enter_Name (Id); 574 Analyze (Nam); 575 576 Set_Ekind (Id, E_Exception); 577 Set_Etype (Id, Standard_Exception_Type); 578 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 579 580 if Is_Entity_Name (Nam) 581 and then Present (Entity (Nam)) 582 and then Ekind (Entity (Nam)) = E_Exception 583 then 584 if Present (Renamed_Object (Entity (Nam))) then 585 Set_Renamed_Object (Id, Renamed_Object (Entity (Nam))); 586 else 587 Set_Renamed_Object (Id, Entity (Nam)); 588 end if; 589 590 -- The exception renaming declaration may become Ghost if it renames 591 -- a Ghost entity. 592 593 Mark_Ghost_Renaming (N, Entity (Nam)); 594 else 595 Error_Msg_N ("invalid exception name in renaming", Nam); 596 end if; 597 598 -- Implementation-defined aspect specifications can appear in a renaming 599 -- declaration, but not language-defined ones. The call to procedure 600 -- Analyze_Aspect_Specifications will take care of this error check. 601 602 if Has_Aspects (N) then 603 Analyze_Aspect_Specifications (N, Id); 604 end if; 605 end Analyze_Exception_Renaming; 606 607 --------------------------- 608 -- Analyze_Expanded_Name -- 609 --------------------------- 610 611 procedure Analyze_Expanded_Name (N : Node_Id) is 612 begin 613 -- If the entity pointer is already set, this is an internal node, or a 614 -- node that is analyzed more than once, after a tree modification. In 615 -- such a case there is no resolution to perform, just set the type. In 616 -- either case, start by analyzing the prefix. 617 618 Analyze (Prefix (N)); 619 620 if Present (Entity (N)) then 621 if Is_Type (Entity (N)) then 622 Set_Etype (N, Entity (N)); 623 else 624 Set_Etype (N, Etype (Entity (N))); 625 end if; 626 627 else 628 Find_Expanded_Name (N); 629 end if; 630 631 -- In either case, propagate dimension of entity to expanded name 632 633 Analyze_Dimension (N); 634 end Analyze_Expanded_Name; 635 636 --------------------------------------- 637 -- Analyze_Generic_Function_Renaming -- 638 --------------------------------------- 639 640 procedure Analyze_Generic_Function_Renaming (N : Node_Id) is 641 begin 642 Analyze_Generic_Renaming (N, E_Generic_Function); 643 end Analyze_Generic_Function_Renaming; 644 645 -------------------------------------- 646 -- Analyze_Generic_Package_Renaming -- 647 -------------------------------------- 648 649 procedure Analyze_Generic_Package_Renaming (N : Node_Id) is 650 begin 651 -- Test for the Text_IO special unit case here, since we may be renaming 652 -- one of the subpackages of Text_IO, then join common routine. 653 654 Check_Text_IO_Special_Unit (Name (N)); 655 656 Analyze_Generic_Renaming (N, E_Generic_Package); 657 end Analyze_Generic_Package_Renaming; 658 659 ---------------------------------------- 660 -- Analyze_Generic_Procedure_Renaming -- 661 ---------------------------------------- 662 663 procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is 664 begin 665 Analyze_Generic_Renaming (N, E_Generic_Procedure); 666 end Analyze_Generic_Procedure_Renaming; 667 668 ------------------------------ 669 -- Analyze_Generic_Renaming -- 670 ------------------------------ 671 672 procedure Analyze_Generic_Renaming 673 (N : Node_Id; 674 K : Entity_Kind) 675 is 676 New_P : constant Entity_Id := Defining_Entity (N); 677 Inst : Boolean := False; 678 Old_P : Entity_Id; 679 680 begin 681 if Name (N) = Error then 682 return; 683 end if; 684 685 Check_SPARK_05_Restriction ("generic renaming is not allowed", N); 686 687 Generate_Definition (New_P); 688 689 if Current_Scope /= Standard_Standard then 690 Set_Is_Pure (New_P, Is_Pure (Current_Scope)); 691 end if; 692 693 if Nkind (Name (N)) = N_Selected_Component then 694 Check_Generic_Child_Unit (Name (N), Inst); 695 else 696 Analyze (Name (N)); 697 end if; 698 699 if not Is_Entity_Name (Name (N)) then 700 Error_Msg_N ("expect entity name in renaming declaration", Name (N)); 701 Old_P := Any_Id; 702 else 703 Old_P := Entity (Name (N)); 704 end if; 705 706 Enter_Name (New_P); 707 Set_Ekind (New_P, K); 708 709 if Etype (Old_P) = Any_Type then 710 null; 711 712 elsif Ekind (Old_P) /= K then 713 Error_Msg_N ("invalid generic unit name", Name (N)); 714 715 else 716 if Present (Renamed_Object (Old_P)) then 717 Set_Renamed_Object (New_P, Renamed_Object (Old_P)); 718 else 719 Set_Renamed_Object (New_P, Old_P); 720 end if; 721 722 -- The generic renaming declaration may become Ghost if it renames a 723 -- Ghost entity. 724 725 Mark_Ghost_Renaming (N, Old_P); 726 727 Set_Is_Pure (New_P, Is_Pure (Old_P)); 728 Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P)); 729 730 Set_Etype (New_P, Etype (Old_P)); 731 Set_Has_Completion (New_P); 732 733 if In_Open_Scopes (Old_P) then 734 Error_Msg_N ("within its scope, generic denotes its instance", N); 735 end if; 736 737 -- For subprograms, propagate the Intrinsic flag, to allow, e.g. 738 -- renamings and subsequent instantiations of Unchecked_Conversion. 739 740 if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then 741 Set_Is_Intrinsic_Subprogram 742 (New_P, Is_Intrinsic_Subprogram (Old_P)); 743 end if; 744 745 Check_Library_Unit_Renaming (N, Old_P); 746 end if; 747 748 -- Implementation-defined aspect specifications can appear in a renaming 749 -- declaration, but not language-defined ones. The call to procedure 750 -- Analyze_Aspect_Specifications will take care of this error check. 751 752 if Has_Aspects (N) then 753 Analyze_Aspect_Specifications (N, New_P); 754 end if; 755 end Analyze_Generic_Renaming; 756 757 ----------------------------- 758 -- Analyze_Object_Renaming -- 759 ----------------------------- 760 761 procedure Analyze_Object_Renaming (N : Node_Id) is 762 Id : constant Entity_Id := Defining_Identifier (N); 763 Loc : constant Source_Ptr := Sloc (N); 764 Nam : constant Node_Id := Name (N); 765 Dec : Node_Id; 766 T : Entity_Id; 767 T2 : Entity_Id; 768 769 procedure Check_Constrained_Object; 770 -- If the nominal type is unconstrained but the renamed object is 771 -- constrained, as can happen with renaming an explicit dereference or 772 -- a function return, build a constrained subtype from the object. If 773 -- the renaming is for a formal in an accept statement, the analysis 774 -- has already established its actual subtype. This is only relevant 775 -- if the renamed object is an explicit dereference. 776 777 ------------------------------ 778 -- Check_Constrained_Object -- 779 ------------------------------ 780 781 procedure Check_Constrained_Object is 782 Typ : constant Entity_Id := Etype (Nam); 783 Subt : Entity_Id; 784 785 begin 786 if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) 787 and then Is_Composite_Type (Etype (Nam)) 788 and then not Is_Constrained (Etype (Nam)) 789 and then not Has_Unknown_Discriminants (Etype (Nam)) 790 and then Expander_Active 791 then 792 -- If Actual_Subtype is already set, nothing to do 793 794 if Ekind_In (Id, E_Variable, E_Constant) 795 and then Present (Actual_Subtype (Id)) 796 then 797 null; 798 799 -- A renaming of an unchecked union has no actual subtype 800 801 elsif Is_Unchecked_Union (Typ) then 802 null; 803 804 -- If a record is limited its size is invariant. This is the case 805 -- in particular with record types with an access discirminant 806 -- that are used in iterators. This is an optimization, but it 807 -- also prevents typing anomalies when the prefix is further 808 -- expanded. Limited types with discriminants are included. 809 810 elsif Is_Limited_Record (Typ) 811 or else 812 (Ekind (Typ) = E_Limited_Private_Type 813 and then Has_Discriminants (Typ) 814 and then Is_Access_Type (Etype (First_Discriminant (Typ)))) 815 then 816 null; 817 818 else 819 Subt := Make_Temporary (Loc, 'T'); 820 Remove_Side_Effects (Nam); 821 Insert_Action (N, 822 Make_Subtype_Declaration (Loc, 823 Defining_Identifier => Subt, 824 Subtype_Indication => 825 Make_Subtype_From_Expr (Nam, Typ))); 826 Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); 827 Set_Etype (Nam, Subt); 828 829 -- Freeze subtype at once, to prevent order of elaboration 830 -- issues in the backend. The renamed object exists, so its 831 -- type is already frozen in any case. 832 833 Freeze_Before (N, Subt); 834 end if; 835 end if; 836 end Check_Constrained_Object; 837 838 -- Start of processing for Analyze_Object_Renaming 839 840 begin 841 if Nam = Error then 842 return; 843 end if; 844 845 Check_SPARK_05_Restriction ("object renaming is not allowed", N); 846 847 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 848 Enter_Name (Id); 849 850 -- The renaming of a component that depends on a discriminant requires 851 -- an actual subtype, because in subsequent use of the object Gigi will 852 -- be unable to locate the actual bounds. This explicit step is required 853 -- when the renaming is generated in removing side effects of an 854 -- already-analyzed expression. 855 856 if Nkind (Nam) = N_Selected_Component and then Analyzed (Nam) then 857 858 -- The object renaming declaration may become Ghost if it renames a 859 -- Ghost entity. 860 861 if Is_Entity_Name (Nam) then 862 Mark_Ghost_Renaming (N, Entity (Nam)); 863 end if; 864 865 T := Etype (Nam); 866 Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam); 867 868 if Present (Dec) then 869 Insert_Action (N, Dec); 870 T := Defining_Identifier (Dec); 871 Set_Etype (Nam, T); 872 end if; 873 874 -- Complete analysis of the subtype mark in any case, for ASIS use 875 876 if Present (Subtype_Mark (N)) then 877 Find_Type (Subtype_Mark (N)); 878 end if; 879 880 elsif Present (Subtype_Mark (N)) then 881 Find_Type (Subtype_Mark (N)); 882 T := Entity (Subtype_Mark (N)); 883 Analyze (Nam); 884 885 -- The object renaming declaration may become Ghost if it renames a 886 -- Ghost entity. 887 888 if Is_Entity_Name (Nam) then 889 Mark_Ghost_Renaming (N, Entity (Nam)); 890 end if; 891 892 -- Reject renamings of conversions unless the type is tagged, or 893 -- the conversion is implicit (which can occur for cases of anonymous 894 -- access types in Ada 2012). 895 896 if Nkind (Nam) = N_Type_Conversion 897 and then Comes_From_Source (Nam) 898 and then not Is_Tagged_Type (T) 899 then 900 Error_Msg_N 901 ("renaming of conversion only allowed for tagged types", Nam); 902 end if; 903 904 Resolve (Nam, T); 905 906 -- If the renamed object is a function call of a limited type, 907 -- the expansion of the renaming is complicated by the presence 908 -- of various temporaries and subtypes that capture constraints 909 -- of the renamed object. Rewrite node as an object declaration, 910 -- whose expansion is simpler. Given that the object is limited 911 -- there is no copy involved and no performance hit. 912 913 if Nkind (Nam) = N_Function_Call 914 and then Is_Limited_View (Etype (Nam)) 915 and then not Is_Constrained (Etype (Nam)) 916 and then Comes_From_Source (N) 917 then 918 Set_Etype (Id, T); 919 Set_Ekind (Id, E_Constant); 920 Rewrite (N, 921 Make_Object_Declaration (Loc, 922 Defining_Identifier => Id, 923 Constant_Present => True, 924 Object_Definition => New_Occurrence_Of (Etype (Nam), Loc), 925 Expression => Relocate_Node (Nam))); 926 return; 927 end if; 928 929 -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object 930 -- when renaming declaration has a named access type. The Ada 2012 931 -- coverage rules allow an anonymous access type in the context of 932 -- an expected named general access type, but the renaming rules 933 -- require the types to be the same. (An exception is when the type 934 -- of the renaming is also an anonymous access type, which can only 935 -- happen due to a renaming created by the expander.) 936 937 if Nkind (Nam) = N_Type_Conversion 938 and then not Comes_From_Source (Nam) 939 and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type 940 and then Ekind (T) /= E_Anonymous_Access_Type 941 then 942 Wrong_Type (Expression (Nam), T); -- Should we give better error??? 943 end if; 944 945 -- Check that a class-wide object is not being renamed as an object 946 -- of a specific type. The test for access types is needed to exclude 947 -- cases where the renamed object is a dynamically tagged access 948 -- result, such as occurs in certain expansions. 949 950 if Is_Tagged_Type (T) then 951 Check_Dynamically_Tagged_Expression 952 (Expr => Nam, 953 Typ => T, 954 Related_Nod => N); 955 end if; 956 957 -- Ada 2005 (AI-230/AI-254): Access renaming 958 959 else pragma Assert (Present (Access_Definition (N))); 960 T := 961 Access_Definition 962 (Related_Nod => N, 963 N => Access_Definition (N)); 964 965 Analyze (Nam); 966 967 -- The object renaming declaration may become Ghost if it renames a 968 -- Ghost entity. 969 970 if Is_Entity_Name (Nam) then 971 Mark_Ghost_Renaming (N, Entity (Nam)); 972 end if; 973 974 -- Ada 2005 AI05-105: if the declaration has an anonymous access 975 -- type, the renamed object must also have an anonymous type, and 976 -- this is a name resolution rule. This was implicit in the last part 977 -- of the first sentence in 8.5.1(3/2), and is made explicit by this 978 -- recent AI. 979 980 if not Is_Overloaded (Nam) then 981 if Ekind (Etype (Nam)) /= Ekind (T) then 982 Error_Msg_N 983 ("expect anonymous access type in object renaming", N); 984 end if; 985 986 else 987 declare 988 I : Interp_Index; 989 It : Interp; 990 Typ : Entity_Id := Empty; 991 Seen : Boolean := False; 992 993 begin 994 Get_First_Interp (Nam, I, It); 995 while Present (It.Typ) loop 996 997 -- Renaming is ambiguous if more than one candidate 998 -- interpretation is type-conformant with the context. 999 1000 if Ekind (It.Typ) = Ekind (T) then 1001 if Ekind (T) = E_Anonymous_Access_Subprogram_Type 1002 and then 1003 Type_Conformant 1004 (Designated_Type (T), Designated_Type (It.Typ)) 1005 then 1006 if not Seen then 1007 Seen := True; 1008 else 1009 Error_Msg_N 1010 ("ambiguous expression in renaming", Nam); 1011 end if; 1012 1013 elsif Ekind (T) = E_Anonymous_Access_Type 1014 and then 1015 Covers (Designated_Type (T), Designated_Type (It.Typ)) 1016 then 1017 if not Seen then 1018 Seen := True; 1019 else 1020 Error_Msg_N 1021 ("ambiguous expression in renaming", Nam); 1022 end if; 1023 end if; 1024 1025 if Covers (T, It.Typ) then 1026 Typ := It.Typ; 1027 Set_Etype (Nam, Typ); 1028 Set_Is_Overloaded (Nam, False); 1029 end if; 1030 end if; 1031 1032 Get_Next_Interp (I, It); 1033 end loop; 1034 end; 1035 end if; 1036 1037 Resolve (Nam, T); 1038 1039 -- Do not perform the legality checks below when the resolution of 1040 -- the renaming name failed because the associated type is Any_Type. 1041 1042 if Etype (Nam) = Any_Type then 1043 null; 1044 1045 -- Ada 2005 (AI-231): In the case where the type is defined by an 1046 -- access_definition, the renamed entity shall be of an access-to- 1047 -- constant type if and only if the access_definition defines an 1048 -- access-to-constant type. ARM 8.5.1(4) 1049 1050 elsif Constant_Present (Access_Definition (N)) 1051 and then not Is_Access_Constant (Etype (Nam)) 1052 then 1053 Error_Msg_N 1054 ("(Ada 2005): the renamed object is not access-to-constant " 1055 & "(RM 8.5.1(6))", N); 1056 1057 elsif not Constant_Present (Access_Definition (N)) 1058 and then Is_Access_Constant (Etype (Nam)) 1059 then 1060 Error_Msg_N 1061 ("(Ada 2005): the renamed object is not access-to-variable " 1062 & "(RM 8.5.1(6))", N); 1063 end if; 1064 1065 if Is_Access_Subprogram_Type (Etype (Nam)) then 1066 Check_Subtype_Conformant 1067 (Designated_Type (T), Designated_Type (Etype (Nam))); 1068 1069 elsif not Subtypes_Statically_Match 1070 (Designated_Type (T), 1071 Available_View (Designated_Type (Etype (Nam)))) 1072 then 1073 Error_Msg_N 1074 ("subtype of renamed object does not statically match", N); 1075 end if; 1076 end if; 1077 1078 -- Special processing for renaming function return object. Some errors 1079 -- and warnings are produced only for calls that come from source. 1080 1081 if Nkind (Nam) = N_Function_Call then 1082 case Ada_Version is 1083 1084 -- Usage is illegal in Ada 83, but renamings are also introduced 1085 -- during expansion, and error does not apply to those. 1086 1087 when Ada_83 => 1088 if Comes_From_Source (N) then 1089 Error_Msg_N 1090 ("(Ada 83) cannot rename function return object", Nam); 1091 end if; 1092 1093 -- In Ada 95, warn for odd case of renaming parameterless function 1094 -- call if this is not a limited type (where this is useful). 1095 1096 when others => 1097 if Warn_On_Object_Renames_Function 1098 and then No (Parameter_Associations (Nam)) 1099 and then not Is_Limited_Type (Etype (Nam)) 1100 and then Comes_From_Source (Nam) 1101 then 1102 Error_Msg_N 1103 ("renaming function result object is suspicious?R?", Nam); 1104 Error_Msg_NE 1105 ("\function & will be called only once?R?", Nam, 1106 Entity (Name (Nam))); 1107 Error_Msg_N -- CODEFIX 1108 ("\suggest using an initialized constant object " 1109 & "instead?R?", Nam); 1110 end if; 1111 end case; 1112 end if; 1113 1114 Check_Constrained_Object; 1115 1116 -- An object renaming requires an exact match of the type. Class-wide 1117 -- matching is not allowed. 1118 1119 if Is_Class_Wide_Type (T) 1120 and then Base_Type (Etype (Nam)) /= Base_Type (T) 1121 then 1122 Wrong_Type (Nam, T); 1123 end if; 1124 1125 T2 := Etype (Nam); 1126 1127 -- Ada 2005 (AI-326): Handle wrong use of incomplete type 1128 1129 if Nkind (Nam) = N_Explicit_Dereference 1130 and then Ekind (Etype (T2)) = E_Incomplete_Type 1131 then 1132 Error_Msg_NE ("invalid use of incomplete type&", Id, T2); 1133 return; 1134 1135 elsif Ekind (Etype (T)) = E_Incomplete_Type then 1136 Error_Msg_NE ("invalid use of incomplete type&", Id, T); 1137 return; 1138 end if; 1139 1140 -- Ada 2005 (AI-327) 1141 1142 if Ada_Version >= Ada_2005 1143 and then Nkind (Nam) = N_Attribute_Reference 1144 and then Attribute_Name (Nam) = Name_Priority 1145 then 1146 null; 1147 1148 elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then 1149 declare 1150 Nam_Decl : Node_Id; 1151 Nam_Ent : Entity_Id; 1152 1153 begin 1154 if Nkind (Nam) = N_Attribute_Reference then 1155 Nam_Ent := Entity (Prefix (Nam)); 1156 else 1157 Nam_Ent := Entity (Nam); 1158 end if; 1159 1160 Nam_Decl := Parent (Nam_Ent); 1161 1162 if Has_Null_Exclusion (N) 1163 and then not Has_Null_Exclusion (Nam_Decl) 1164 then 1165 -- Ada 2005 (AI-423): If the object name denotes a generic 1166 -- formal object of a generic unit G, and the object renaming 1167 -- declaration occurs within the body of G or within the body 1168 -- of a generic unit declared within the declarative region 1169 -- of G, then the declaration of the formal object of G must 1170 -- have a null exclusion or a null-excluding subtype. 1171 1172 if Is_Formal_Object (Nam_Ent) 1173 and then In_Generic_Scope (Id) 1174 then 1175 if not Can_Never_Be_Null (Etype (Nam_Ent)) then 1176 Error_Msg_N 1177 ("renamed formal does not exclude `NULL` " 1178 & "(RM 8.5.1(4.6/2))", N); 1179 1180 elsif In_Package_Body (Scope (Id)) then 1181 Error_Msg_N 1182 ("formal object does not have a null exclusion" 1183 & "(RM 8.5.1(4.6/2))", N); 1184 end if; 1185 1186 -- Ada 2005 (AI-423): Otherwise, the subtype of the object name 1187 -- shall exclude null. 1188 1189 elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then 1190 Error_Msg_N 1191 ("renamed object does not exclude `NULL` " 1192 & "(RM 8.5.1(4.6/2))", N); 1193 1194 -- An instance is illegal if it contains a renaming that 1195 -- excludes null, and the actual does not. The renaming 1196 -- declaration has already indicated that the declaration 1197 -- of the renamed actual in the instance will raise 1198 -- constraint_error. 1199 1200 elsif Nkind (Nam_Decl) = N_Object_Declaration 1201 and then In_Instance 1202 and then 1203 Present (Corresponding_Generic_Association (Nam_Decl)) 1204 and then Nkind (Expression (Nam_Decl)) = 1205 N_Raise_Constraint_Error 1206 then 1207 Error_Msg_N 1208 ("renamed actual does not exclude `NULL` " 1209 & "(RM 8.5.1(4.6/2))", N); 1210 1211 -- Finally, if there is a null exclusion, the subtype mark 1212 -- must not be null-excluding. 1213 1214 elsif No (Access_Definition (N)) 1215 and then Can_Never_Be_Null (T) 1216 then 1217 Error_Msg_NE 1218 ("`NOT NULL` not allowed (& already excludes null)", 1219 N, T); 1220 1221 end if; 1222 1223 elsif Can_Never_Be_Null (T) 1224 and then not Can_Never_Be_Null (Etype (Nam_Ent)) 1225 then 1226 Error_Msg_N 1227 ("renamed object does not exclude `NULL` " 1228 & "(RM 8.5.1(4.6/2))", N); 1229 1230 elsif Has_Null_Exclusion (N) 1231 and then No (Access_Definition (N)) 1232 and then Can_Never_Be_Null (T) 1233 then 1234 Error_Msg_NE 1235 ("`NOT NULL` not allowed (& already excludes null)", N, T); 1236 end if; 1237 end; 1238 end if; 1239 1240 -- Set the Ekind of the entity, unless it has been set already, as is 1241 -- the case for the iteration object over a container with no variable 1242 -- indexing. In that case it's been marked as a constant, and we do not 1243 -- want to change it to a variable. 1244 1245 if Ekind (Id) /= E_Constant then 1246 Set_Ekind (Id, E_Variable); 1247 end if; 1248 1249 -- Initialize the object size and alignment. Note that we used to call 1250 -- Init_Size_Align here, but that's wrong for objects which have only 1251 -- an Esize, not an RM_Size field. 1252 1253 Init_Object_Size_Align (Id); 1254 1255 if T = Any_Type or else Etype (Nam) = Any_Type then 1256 return; 1257 1258 -- Verify that the renamed entity is an object or a function call. It 1259 -- may have been rewritten in several ways. 1260 1261 elsif Is_Object_Reference (Nam) then 1262 if Comes_From_Source (N) then 1263 if Is_Dependent_Component_Of_Mutable_Object (Nam) then 1264 Error_Msg_N 1265 ("illegal renaming of discriminant-dependent component", Nam); 1266 end if; 1267 1268 -- If the renaming comes from source and the renamed object is a 1269 -- dereference, then mark the prefix as needing debug information, 1270 -- since it might have been rewritten hence internally generated 1271 -- and Debug_Renaming_Declaration will link the renaming to it. 1272 1273 if Nkind (Nam) = N_Explicit_Dereference 1274 and then Is_Entity_Name (Prefix (Nam)) 1275 then 1276 Set_Debug_Info_Needed (Entity (Prefix (Nam))); 1277 end if; 1278 end if; 1279 1280 -- A static function call may have been folded into a literal 1281 1282 elsif Nkind (Original_Node (Nam)) = N_Function_Call 1283 1284 -- When expansion is disabled, attribute reference is not rewritten 1285 -- as function call. Otherwise it may be rewritten as a conversion, 1286 -- so check original node. 1287 1288 or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference 1289 and then Is_Function_Attribute_Name 1290 (Attribute_Name (Original_Node (Nam)))) 1291 1292 -- Weird but legal, equivalent to renaming a function call. Illegal 1293 -- if the literal is the result of constant-folding an attribute 1294 -- reference that is not a function. 1295 1296 or else (Is_Entity_Name (Nam) 1297 and then Ekind (Entity (Nam)) = E_Enumeration_Literal 1298 and then 1299 Nkind (Original_Node (Nam)) /= N_Attribute_Reference) 1300 1301 or else (Nkind (Nam) = N_Type_Conversion 1302 and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) 1303 then 1304 null; 1305 1306 elsif Nkind (Nam) = N_Type_Conversion then 1307 Error_Msg_N 1308 ("renaming of conversion only allowed for tagged types", Nam); 1309 1310 -- Ada 2005 (AI-327) 1311 1312 elsif Ada_Version >= Ada_2005 1313 and then Nkind (Nam) = N_Attribute_Reference 1314 and then Attribute_Name (Nam) = Name_Priority 1315 then 1316 null; 1317 1318 -- Allow internally generated x'Ref resulting in N_Reference node 1319 1320 elsif Nkind (Nam) = N_Reference then 1321 null; 1322 1323 else 1324 Error_Msg_N ("expect object name in renaming", Nam); 1325 end if; 1326 1327 Set_Etype (Id, T2); 1328 1329 if not Is_Variable (Nam) then 1330 Set_Ekind (Id, E_Constant); 1331 Set_Never_Set_In_Source (Id, True); 1332 Set_Is_True_Constant (Id, True); 1333 end if; 1334 1335 -- The entity of the renaming declaration needs to reflect whether the 1336 -- renamed object is volatile. Is_Volatile is set if the renamed object 1337 -- is volatile in the RM legality sense. 1338 1339 Set_Is_Volatile (Id, Is_Volatile_Object (Nam)); 1340 1341 -- Also copy settings of Atomic/Independent/Volatile_Full_Access 1342 1343 if Is_Entity_Name (Nam) then 1344 Set_Is_Atomic (Id, Is_Atomic (Entity (Nam))); 1345 Set_Is_Independent (Id, Is_Independent (Entity (Nam))); 1346 Set_Is_Volatile_Full_Access (Id, 1347 Is_Volatile_Full_Access (Entity (Nam))); 1348 end if; 1349 1350 -- Treat as volatile if we just set the Volatile flag 1351 1352 if Is_Volatile (Id) 1353 1354 -- Or if we are renaming an entity which was marked this way 1355 1356 -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ??? 1357 1358 or else (Is_Entity_Name (Nam) 1359 and then Treat_As_Volatile (Entity (Nam))) 1360 then 1361 Set_Treat_As_Volatile (Id, True); 1362 end if; 1363 1364 -- Now make the link to the renamed object 1365 1366 Set_Renamed_Object (Id, Nam); 1367 1368 -- Implementation-defined aspect specifications can appear in a renaming 1369 -- declaration, but not language-defined ones. The call to procedure 1370 -- Analyze_Aspect_Specifications will take care of this error check. 1371 1372 if Has_Aspects (N) then 1373 Analyze_Aspect_Specifications (N, Id); 1374 end if; 1375 1376 -- Deal with dimensions 1377 1378 Analyze_Dimension (N); 1379 end Analyze_Object_Renaming; 1380 1381 ------------------------------ 1382 -- Analyze_Package_Renaming -- 1383 ------------------------------ 1384 1385 procedure Analyze_Package_Renaming (N : Node_Id) is 1386 New_P : constant Entity_Id := Defining_Entity (N); 1387 Old_P : Entity_Id; 1388 Spec : Node_Id; 1389 1390 begin 1391 if Name (N) = Error then 1392 return; 1393 end if; 1394 1395 -- Check for Text_IO special unit (we may be renaming a Text_IO child) 1396 1397 Check_Text_IO_Special_Unit (Name (N)); 1398 1399 if Current_Scope /= Standard_Standard then 1400 Set_Is_Pure (New_P, Is_Pure (Current_Scope)); 1401 end if; 1402 1403 Enter_Name (New_P); 1404 Analyze (Name (N)); 1405 1406 if Is_Entity_Name (Name (N)) then 1407 Old_P := Entity (Name (N)); 1408 else 1409 Old_P := Any_Id; 1410 end if; 1411 1412 if Etype (Old_P) = Any_Type then 1413 Error_Msg_N ("expect package name in renaming", Name (N)); 1414 1415 elsif Ekind (Old_P) /= E_Package 1416 and then not (Ekind (Old_P) = E_Generic_Package 1417 and then In_Open_Scopes (Old_P)) 1418 then 1419 if Ekind (Old_P) = E_Generic_Package then 1420 Error_Msg_N 1421 ("generic package cannot be renamed as a package", Name (N)); 1422 else 1423 Error_Msg_Sloc := Sloc (Old_P); 1424 Error_Msg_NE 1425 ("expect package name in renaming, found& declared#", 1426 Name (N), Old_P); 1427 end if; 1428 1429 -- Set basic attributes to minimize cascaded errors 1430 1431 Set_Ekind (New_P, E_Package); 1432 Set_Etype (New_P, Standard_Void_Type); 1433 1434 -- Here for OK package renaming 1435 1436 else 1437 -- Entities in the old package are accessible through the renaming 1438 -- entity. The simplest implementation is to have both packages share 1439 -- the entity list. 1440 1441 Set_Ekind (New_P, E_Package); 1442 Set_Etype (New_P, Standard_Void_Type); 1443 1444 if Present (Renamed_Object (Old_P)) then 1445 Set_Renamed_Object (New_P, Renamed_Object (Old_P)); 1446 else 1447 Set_Renamed_Object (New_P, Old_P); 1448 end if; 1449 1450 -- The package renaming declaration may become Ghost if it renames a 1451 -- Ghost entity. 1452 1453 Mark_Ghost_Renaming (N, Old_P); 1454 1455 Set_Has_Completion (New_P); 1456 Set_First_Entity (New_P, First_Entity (Old_P)); 1457 Set_Last_Entity (New_P, Last_Entity (Old_P)); 1458 Set_First_Private_Entity (New_P, First_Private_Entity (Old_P)); 1459 Check_Library_Unit_Renaming (N, Old_P); 1460 Generate_Reference (Old_P, Name (N)); 1461 1462 -- If the renaming is in the visible part of a package, then we set 1463 -- Renamed_In_Spec for the renamed package, to prevent giving 1464 -- warnings about no entities referenced. Such a warning would be 1465 -- overenthusiastic, since clients can see entities in the renamed 1466 -- package via the visible package renaming. 1467 1468 declare 1469 Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 1470 begin 1471 if Ekind (Ent) = E_Package 1472 and then not In_Private_Part (Ent) 1473 and then In_Extended_Main_Source_Unit (N) 1474 and then Ekind (Old_P) = E_Package 1475 then 1476 Set_Renamed_In_Spec (Old_P); 1477 end if; 1478 end; 1479 1480 -- If this is the renaming declaration of a package instantiation 1481 -- within itself, it is the declaration that ends the list of actuals 1482 -- for the instantiation. At this point, the subtypes that rename 1483 -- the actuals are flagged as generic, to avoid spurious ambiguities 1484 -- if the actuals for two distinct formals happen to coincide. If 1485 -- the actual is a private type, the subtype has a private completion 1486 -- that is flagged in the same fashion. 1487 1488 -- Resolution is identical to what is was in the original generic. 1489 -- On exit from the generic instance, these are turned into regular 1490 -- subtypes again, so they are compatible with types in their class. 1491 1492 if not Is_Generic_Instance (Old_P) then 1493 return; 1494 else 1495 Spec := Specification (Unit_Declaration_Node (Old_P)); 1496 end if; 1497 1498 if Nkind (Spec) = N_Package_Specification 1499 and then Present (Generic_Parent (Spec)) 1500 and then Old_P = Current_Scope 1501 and then Chars (New_P) = Chars (Generic_Parent (Spec)) 1502 then 1503 declare 1504 E : Entity_Id; 1505 1506 begin 1507 E := First_Entity (Old_P); 1508 while Present (E) and then E /= New_P loop 1509 if Is_Type (E) 1510 and then Nkind (Parent (E)) = N_Subtype_Declaration 1511 then 1512 Set_Is_Generic_Actual_Type (E); 1513 1514 if Is_Private_Type (E) 1515 and then Present (Full_View (E)) 1516 then 1517 Set_Is_Generic_Actual_Type (Full_View (E)); 1518 end if; 1519 end if; 1520 1521 Next_Entity (E); 1522 end loop; 1523 end; 1524 end if; 1525 end if; 1526 1527 -- Implementation-defined aspect specifications can appear in a renaming 1528 -- declaration, but not language-defined ones. The call to procedure 1529 -- Analyze_Aspect_Specifications will take care of this error check. 1530 1531 if Has_Aspects (N) then 1532 Analyze_Aspect_Specifications (N, New_P); 1533 end if; 1534 end Analyze_Package_Renaming; 1535 1536 ------------------------------- 1537 -- Analyze_Renamed_Character -- 1538 ------------------------------- 1539 1540 procedure Analyze_Renamed_Character 1541 (N : Node_Id; 1542 New_S : Entity_Id; 1543 Is_Body : Boolean) 1544 is 1545 C : constant Node_Id := Name (N); 1546 1547 begin 1548 if Ekind (New_S) = E_Function then 1549 Resolve (C, Etype (New_S)); 1550 1551 if Is_Body then 1552 Check_Frozen_Renaming (N, New_S); 1553 end if; 1554 1555 else 1556 Error_Msg_N ("character literal can only be renamed as function", N); 1557 end if; 1558 end Analyze_Renamed_Character; 1559 1560 --------------------------------- 1561 -- Analyze_Renamed_Dereference -- 1562 --------------------------------- 1563 1564 procedure Analyze_Renamed_Dereference 1565 (N : Node_Id; 1566 New_S : Entity_Id; 1567 Is_Body : Boolean) 1568 is 1569 Nam : constant Node_Id := Name (N); 1570 P : constant Node_Id := Prefix (Nam); 1571 Typ : Entity_Id; 1572 Ind : Interp_Index; 1573 It : Interp; 1574 1575 begin 1576 if not Is_Overloaded (P) then 1577 if Ekind (Etype (Nam)) /= E_Subprogram_Type 1578 or else not Type_Conformant (Etype (Nam), New_S) 1579 then 1580 Error_Msg_N ("designated type does not match specification", P); 1581 else 1582 Resolve (P); 1583 end if; 1584 1585 return; 1586 1587 else 1588 Typ := Any_Type; 1589 Get_First_Interp (Nam, Ind, It); 1590 1591 while Present (It.Nam) loop 1592 1593 if Ekind (It.Nam) = E_Subprogram_Type 1594 and then Type_Conformant (It.Nam, New_S) 1595 then 1596 if Typ /= Any_Id then 1597 Error_Msg_N ("ambiguous renaming", P); 1598 return; 1599 else 1600 Typ := It.Nam; 1601 end if; 1602 end if; 1603 1604 Get_Next_Interp (Ind, It); 1605 end loop; 1606 1607 if Typ = Any_Type then 1608 Error_Msg_N ("designated type does not match specification", P); 1609 else 1610 Resolve (N, Typ); 1611 1612 if Is_Body then 1613 Check_Frozen_Renaming (N, New_S); 1614 end if; 1615 end if; 1616 end if; 1617 end Analyze_Renamed_Dereference; 1618 1619 --------------------------- 1620 -- Analyze_Renamed_Entry -- 1621 --------------------------- 1622 1623 procedure Analyze_Renamed_Entry 1624 (N : Node_Id; 1625 New_S : Entity_Id; 1626 Is_Body : Boolean) 1627 is 1628 Nam : constant Node_Id := Name (N); 1629 Sel : constant Node_Id := Selector_Name (Nam); 1630 Is_Actual : constant Boolean := Present (Corresponding_Formal_Spec (N)); 1631 Old_S : Entity_Id; 1632 1633 begin 1634 if Entity (Sel) = Any_Id then 1635 1636 -- Selector is undefined on prefix. Error emitted already 1637 1638 Set_Has_Completion (New_S); 1639 return; 1640 end if; 1641 1642 -- Otherwise find renamed entity and build body of New_S as a call to it 1643 1644 Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); 1645 1646 if Old_S = Any_Id then 1647 Error_Msg_N (" no subprogram or entry matches specification", N); 1648 else 1649 if Is_Body then 1650 Check_Subtype_Conformant (New_S, Old_S, N); 1651 Generate_Reference (New_S, Defining_Entity (N), 'b'); 1652 Style.Check_Identifier (Defining_Entity (N), New_S); 1653 1654 else 1655 -- Only mode conformance required for a renaming_as_declaration 1656 1657 Check_Mode_Conformant (New_S, Old_S, N); 1658 end if; 1659 1660 Inherit_Renamed_Profile (New_S, Old_S); 1661 1662 -- The prefix can be an arbitrary expression that yields a task or 1663 -- protected object, so it must be resolved. 1664 1665 Resolve (Prefix (Nam), Scope (Old_S)); 1666 end if; 1667 1668 Set_Convention (New_S, Convention (Old_S)); 1669 Set_Has_Completion (New_S, Inside_A_Generic); 1670 1671 -- AI05-0225: If the renamed entity is a procedure or entry of a 1672 -- protected object, the target object must be a variable. 1673 1674 if Ekind (Scope (Old_S)) in Protected_Kind 1675 and then Ekind (New_S) = E_Procedure 1676 and then not Is_Variable (Prefix (Nam)) 1677 then 1678 if Is_Actual then 1679 Error_Msg_N 1680 ("target object of protected operation used as actual for " 1681 & "formal procedure must be a variable", Nam); 1682 else 1683 Error_Msg_N 1684 ("target object of protected operation renamed as procedure, " 1685 & "must be a variable", Nam); 1686 end if; 1687 end if; 1688 1689 if Is_Body then 1690 Check_Frozen_Renaming (N, New_S); 1691 end if; 1692 end Analyze_Renamed_Entry; 1693 1694 ----------------------------------- 1695 -- Analyze_Renamed_Family_Member -- 1696 ----------------------------------- 1697 1698 procedure Analyze_Renamed_Family_Member 1699 (N : Node_Id; 1700 New_S : Entity_Id; 1701 Is_Body : Boolean) 1702 is 1703 Nam : constant Node_Id := Name (N); 1704 P : constant Node_Id := Prefix (Nam); 1705 Old_S : Entity_Id; 1706 1707 begin 1708 if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) 1709 or else (Nkind (P) = N_Selected_Component 1710 and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family) 1711 then 1712 if Is_Entity_Name (P) then 1713 Old_S := Entity (P); 1714 else 1715 Old_S := Entity (Selector_Name (P)); 1716 end if; 1717 1718 if not Entity_Matches_Spec (Old_S, New_S) then 1719 Error_Msg_N ("entry family does not match specification", N); 1720 1721 elsif Is_Body then 1722 Check_Subtype_Conformant (New_S, Old_S, N); 1723 Generate_Reference (New_S, Defining_Entity (N), 'b'); 1724 Style.Check_Identifier (Defining_Entity (N), New_S); 1725 end if; 1726 1727 else 1728 Error_Msg_N ("no entry family matches specification", N); 1729 end if; 1730 1731 Set_Has_Completion (New_S, Inside_A_Generic); 1732 1733 if Is_Body then 1734 Check_Frozen_Renaming (N, New_S); 1735 end if; 1736 end Analyze_Renamed_Family_Member; 1737 1738 ----------------------------------------- 1739 -- Analyze_Renamed_Primitive_Operation -- 1740 ----------------------------------------- 1741 1742 procedure Analyze_Renamed_Primitive_Operation 1743 (N : Node_Id; 1744 New_S : Entity_Id; 1745 Is_Body : Boolean) 1746 is 1747 Old_S : Entity_Id; 1748 1749 function Conforms 1750 (Subp : Entity_Id; 1751 Ctyp : Conformance_Type) return Boolean; 1752 -- Verify that the signatures of the renamed entity and the new entity 1753 -- match. The first formal of the renamed entity is skipped because it 1754 -- is the target object in any subsequent call. 1755 1756 -------------- 1757 -- Conforms -- 1758 -------------- 1759 1760 function Conforms 1761 (Subp : Entity_Id; 1762 Ctyp : Conformance_Type) return Boolean 1763 is 1764 Old_F : Entity_Id; 1765 New_F : Entity_Id; 1766 1767 begin 1768 if Ekind (Subp) /= Ekind (New_S) then 1769 return False; 1770 end if; 1771 1772 Old_F := Next_Formal (First_Formal (Subp)); 1773 New_F := First_Formal (New_S); 1774 while Present (Old_F) and then Present (New_F) loop 1775 if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then 1776 return False; 1777 end if; 1778 1779 if Ctyp >= Mode_Conformant 1780 and then Ekind (Old_F) /= Ekind (New_F) 1781 then 1782 return False; 1783 end if; 1784 1785 Next_Formal (New_F); 1786 Next_Formal (Old_F); 1787 end loop; 1788 1789 return True; 1790 end Conforms; 1791 1792 -- Start of processing for Analyze_Renamed_Primitive_Operation 1793 1794 begin 1795 if not Is_Overloaded (Selector_Name (Name (N))) then 1796 Old_S := Entity (Selector_Name (Name (N))); 1797 1798 if not Conforms (Old_S, Type_Conformant) then 1799 Old_S := Any_Id; 1800 end if; 1801 1802 else 1803 -- Find the operation that matches the given signature 1804 1805 declare 1806 It : Interp; 1807 Ind : Interp_Index; 1808 1809 begin 1810 Old_S := Any_Id; 1811 Get_First_Interp (Selector_Name (Name (N)), Ind, It); 1812 1813 while Present (It.Nam) loop 1814 if Conforms (It.Nam, Type_Conformant) then 1815 Old_S := It.Nam; 1816 end if; 1817 1818 Get_Next_Interp (Ind, It); 1819 end loop; 1820 end; 1821 end if; 1822 1823 if Old_S = Any_Id then 1824 Error_Msg_N (" no subprogram or entry matches specification", N); 1825 1826 else 1827 if Is_Body then 1828 if not Conforms (Old_S, Subtype_Conformant) then 1829 Error_Msg_N ("subtype conformance error in renaming", N); 1830 end if; 1831 1832 Generate_Reference (New_S, Defining_Entity (N), 'b'); 1833 Style.Check_Identifier (Defining_Entity (N), New_S); 1834 1835 else 1836 -- Only mode conformance required for a renaming_as_declaration 1837 1838 if not Conforms (Old_S, Mode_Conformant) then 1839 Error_Msg_N ("mode conformance error in renaming", N); 1840 end if; 1841 1842 -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed 1843 -- view of a subprogram is intrinsic, because the compiler has 1844 -- to generate a wrapper for any call to it. If the name in a 1845 -- subprogram renaming is a prefixed view, the entity is thus 1846 -- intrinsic, and 'Access cannot be applied to it. 1847 1848 Set_Convention (New_S, Convention_Intrinsic); 1849 end if; 1850 1851 -- Inherit_Renamed_Profile (New_S, Old_S); 1852 1853 -- The prefix can be an arbitrary expression that yields an 1854 -- object, so it must be resolved. 1855 1856 Resolve (Prefix (Name (N))); 1857 end if; 1858 end Analyze_Renamed_Primitive_Operation; 1859 1860 --------------------------------- 1861 -- Analyze_Subprogram_Renaming -- 1862 --------------------------------- 1863 1864 procedure Analyze_Subprogram_Renaming (N : Node_Id) is 1865 Formal_Spec : constant Entity_Id := Corresponding_Formal_Spec (N); 1866 Is_Actual : constant Boolean := Present (Formal_Spec); 1867 Nam : constant Node_Id := Name (N); 1868 Save_AV : constant Ada_Version_Type := Ada_Version; 1869 Save_AVP : constant Node_Id := Ada_Version_Pragma; 1870 Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; 1871 Spec : constant Node_Id := Specification (N); 1872 1873 Old_S : Entity_Id := Empty; 1874 Rename_Spec : Entity_Id; 1875 1876 procedure Build_Class_Wide_Wrapper 1877 (Ren_Id : out Entity_Id; 1878 Wrap_Id : out Entity_Id); 1879 -- Ada 2012 (AI05-0071): A generic/instance scenario involving a formal 1880 -- type with unknown discriminants and a generic primitive operation of 1881 -- the said type with a box require special processing when the actual 1882 -- is a class-wide type: 1883 -- 1884 -- generic 1885 -- type Formal_Typ (<>) is private; 1886 -- with procedure Prim_Op (Param : Formal_Typ) is <>; 1887 -- package Gen is ... 1888 -- 1889 -- package Inst is new Gen (Actual_Typ'Class); 1890 -- 1891 -- In this case the general renaming mechanism used in the prologue of 1892 -- an instance no longer applies: 1893 -- 1894 -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; 1895 -- 1896 -- The above is replaced the following wrapper/renaming combination: 1897 -- 1898 -- procedure Wrapper (Param : Formal_Typ) is -- wrapper 1899 -- begin 1900 -- Prim_Op (Param); -- primitive 1901 -- end Wrapper; 1902 -- 1903 -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper; 1904 -- 1905 -- This transformation applies only if there is no explicit visible 1906 -- class-wide operation at the point of the instantiation. Ren_Id is 1907 -- the entity of the renaming declaration. When the transformation 1908 -- applies, Wrap_Id is the entity of the generated class-wide wrapper 1909 -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide 1910 -- operation. 1911 1912 procedure Check_Null_Exclusion 1913 (Ren : Entity_Id; 1914 Sub : Entity_Id); 1915 -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the 1916 -- following AI rules: 1917 -- 1918 -- If Ren is a renaming of a formal subprogram and one of its 1919 -- parameters has a null exclusion, then the corresponding formal 1920 -- in Sub must also have one. Otherwise the subtype of the Sub's 1921 -- formal parameter must exclude null. 1922 -- 1923 -- If Ren is a renaming of a formal function and its return 1924 -- profile has a null exclusion, then Sub's return profile must 1925 -- have one. Otherwise the subtype of Sub's return profile must 1926 -- exclude null. 1927 1928 procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id); 1929 -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not 1930 -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)). 1931 1932 procedure Freeze_Actual_Profile; 1933 -- In Ada 2012, enforce the freezing rule concerning formal incomplete 1934 -- types: a callable entity freezes its profile, unless it has an 1935 -- incomplete untagged formal (RM 13.14(10.2/3)). 1936 1937 function Has_Class_Wide_Actual return Boolean; 1938 -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a 1939 -- defaulted formal subprogram where the actual for the controlling 1940 -- formal type is class-wide. 1941 1942 function Original_Subprogram (Subp : Entity_Id) return Entity_Id; 1943 -- Find renamed entity when the declaration is a renaming_as_body and 1944 -- the renamed entity may itself be a renaming_as_body. Used to enforce 1945 -- rule that a renaming_as_body is illegal if the declaration occurs 1946 -- before the subprogram it completes is frozen, and renaming indirectly 1947 -- renames the subprogram itself.(Defect Report 8652/0027). 1948 1949 ------------------------------ 1950 -- Build_Class_Wide_Wrapper -- 1951 ------------------------------ 1952 1953 procedure Build_Class_Wide_Wrapper 1954 (Ren_Id : out Entity_Id; 1955 Wrap_Id : out Entity_Id) 1956 is 1957 Loc : constant Source_Ptr := Sloc (N); 1958 1959 function Build_Call 1960 (Subp_Id : Entity_Id; 1961 Params : List_Id) return Node_Id; 1962 -- Create a dispatching call to invoke routine Subp_Id with actuals 1963 -- built from the parameter specifications of list Params. 1964 1965 function Build_Expr_Fun_Call 1966 (Subp_Id : Entity_Id; 1967 Params : List_Id) return Node_Id; 1968 -- Create a dispatching call to invoke function Subp_Id with actuals 1969 -- built from the parameter specifications of list Params. Return 1970 -- directly the call, so that it can be used inside an expression 1971 -- function. This is a specificity of the GNATprove mode. 1972 1973 function Build_Spec (Subp_Id : Entity_Id) return Node_Id; 1974 -- Create a subprogram specification based on the subprogram profile 1975 -- of Subp_Id. 1976 1977 function Find_Primitive (Typ : Entity_Id) return Entity_Id; 1978 -- Find a primitive subprogram of type Typ which matches the profile 1979 -- of the renaming declaration. 1980 1981 procedure Interpretation_Error (Subp_Id : Entity_Id); 1982 -- Emit a continuation error message suggesting subprogram Subp_Id as 1983 -- a possible interpretation. 1984 1985 function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean; 1986 -- Determine whether subprogram Subp_Id denotes the intrinsic "=" 1987 -- operator. 1988 1989 function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean; 1990 -- Determine whether subprogram Subp_Id is a suitable candidate for 1991 -- the role of a wrapped subprogram. 1992 1993 ---------------- 1994 -- Build_Call -- 1995 ---------------- 1996 1997 function Build_Call 1998 (Subp_Id : Entity_Id; 1999 Params : List_Id) return Node_Id 2000 is 2001 Actuals : constant List_Id := New_List; 2002 Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); 2003 Formal : Node_Id; 2004 2005 begin 2006 -- Build the actual parameters of the call 2007 2008 Formal := First (Params); 2009 while Present (Formal) loop 2010 Append_To (Actuals, 2011 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 2012 Next (Formal); 2013 end loop; 2014 2015 -- Generate: 2016 -- return Subp_Id (Actuals); 2017 2018 if Ekind_In (Subp_Id, E_Function, E_Operator) then 2019 return 2020 Make_Simple_Return_Statement (Loc, 2021 Expression => 2022 Make_Function_Call (Loc, 2023 Name => Call_Ref, 2024 Parameter_Associations => Actuals)); 2025 2026 -- Generate: 2027 -- Subp_Id (Actuals); 2028 2029 else 2030 return 2031 Make_Procedure_Call_Statement (Loc, 2032 Name => Call_Ref, 2033 Parameter_Associations => Actuals); 2034 end if; 2035 end Build_Call; 2036 2037 ------------------------- 2038 -- Build_Expr_Fun_Call -- 2039 ------------------------- 2040 2041 function Build_Expr_Fun_Call 2042 (Subp_Id : Entity_Id; 2043 Params : List_Id) return Node_Id 2044 is 2045 Actuals : constant List_Id := New_List; 2046 Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); 2047 Formal : Node_Id; 2048 2049 begin 2050 pragma Assert (Ekind_In (Subp_Id, E_Function, E_Operator)); 2051 2052 -- Build the actual parameters of the call 2053 2054 Formal := First (Params); 2055 while Present (Formal) loop 2056 Append_To (Actuals, 2057 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 2058 Next (Formal); 2059 end loop; 2060 2061 -- Generate: 2062 -- Subp_Id (Actuals); 2063 2064 return 2065 Make_Function_Call (Loc, 2066 Name => Call_Ref, 2067 Parameter_Associations => Actuals); 2068 end Build_Expr_Fun_Call; 2069 2070 ---------------- 2071 -- Build_Spec -- 2072 ---------------- 2073 2074 function Build_Spec (Subp_Id : Entity_Id) return Node_Id is 2075 Params : constant List_Id := Copy_Parameter_List (Subp_Id); 2076 Spec_Id : constant Entity_Id := 2077 Make_Defining_Identifier (Loc, 2078 Chars => New_External_Name (Chars (Subp_Id), 'R')); 2079 2080 begin 2081 if Ekind (Formal_Spec) = E_Procedure then 2082 return 2083 Make_Procedure_Specification (Loc, 2084 Defining_Unit_Name => Spec_Id, 2085 Parameter_Specifications => Params); 2086 else 2087 return 2088 Make_Function_Specification (Loc, 2089 Defining_Unit_Name => Spec_Id, 2090 Parameter_Specifications => Params, 2091 Result_Definition => 2092 New_Copy_Tree (Result_Definition (Spec))); 2093 end if; 2094 end Build_Spec; 2095 2096 -------------------- 2097 -- Find_Primitive -- 2098 -------------------- 2099 2100 function Find_Primitive (Typ : Entity_Id) return Entity_Id is 2101 procedure Replace_Parameter_Types (Spec : Node_Id); 2102 -- Given a specification Spec, replace all class-wide parameter 2103 -- types with reference to type Typ. 2104 2105 ----------------------------- 2106 -- Replace_Parameter_Types -- 2107 ----------------------------- 2108 2109 procedure Replace_Parameter_Types (Spec : Node_Id) is 2110 Formal : Node_Id; 2111 Formal_Id : Entity_Id; 2112 Formal_Typ : Node_Id; 2113 2114 begin 2115 Formal := First (Parameter_Specifications (Spec)); 2116 while Present (Formal) loop 2117 Formal_Id := Defining_Identifier (Formal); 2118 Formal_Typ := Parameter_Type (Formal); 2119 2120 -- Create a new entity for each class-wide formal to prevent 2121 -- aliasing with the original renaming. Replace the type of 2122 -- such a parameter with the candidate type. 2123 2124 if Nkind (Formal_Typ) = N_Identifier 2125 and then Is_Class_Wide_Type (Etype (Formal_Typ)) 2126 then 2127 Set_Defining_Identifier (Formal, 2128 Make_Defining_Identifier (Loc, Chars (Formal_Id))); 2129 2130 Set_Parameter_Type (Formal, New_Occurrence_Of (Typ, Loc)); 2131 end if; 2132 2133 Next (Formal); 2134 end loop; 2135 end Replace_Parameter_Types; 2136 2137 -- Local variables 2138 2139 Alt_Ren : constant Node_Id := New_Copy_Tree (N); 2140 Alt_Nam : constant Node_Id := Name (Alt_Ren); 2141 Alt_Spec : constant Node_Id := Specification (Alt_Ren); 2142 Subp_Id : Entity_Id; 2143 2144 -- Start of processing for Find_Primitive 2145 2146 begin 2147 -- Each attempt to find a suitable primitive of a particular type 2148 -- operates on its own copy of the original renaming. As a result 2149 -- the original renaming is kept decoration and side-effect free. 2150 2151 -- Inherit the overloaded status of the renamed subprogram name 2152 2153 if Is_Overloaded (Nam) then 2154 Set_Is_Overloaded (Alt_Nam); 2155 Save_Interps (Nam, Alt_Nam); 2156 end if; 2157 2158 -- The copied renaming is hidden from visibility to prevent the 2159 -- pollution of the enclosing context. 2160 2161 Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R')); 2162 2163 -- The types of all class-wide parameters must be changed to the 2164 -- candidate type. 2165 2166 Replace_Parameter_Types (Alt_Spec); 2167 2168 -- Try to find a suitable primitive which matches the altered 2169 -- profile of the renaming specification. 2170 2171 Subp_Id := 2172 Find_Renamed_Entity 2173 (N => Alt_Ren, 2174 Nam => Name (Alt_Ren), 2175 New_S => Analyze_Subprogram_Specification (Alt_Spec), 2176 Is_Actual => Is_Actual); 2177 2178 -- Do not return Any_Id if the resolion of the altered profile 2179 -- failed as this complicates further checks on the caller side, 2180 -- return Empty instead. 2181 2182 if Subp_Id = Any_Id then 2183 return Empty; 2184 else 2185 return Subp_Id; 2186 end if; 2187 end Find_Primitive; 2188 2189 -------------------------- 2190 -- Interpretation_Error -- 2191 -------------------------- 2192 2193 procedure Interpretation_Error (Subp_Id : Entity_Id) is 2194 begin 2195 Error_Msg_Sloc := Sloc (Subp_Id); 2196 2197 if Is_Internal (Subp_Id) then 2198 Error_Msg_NE 2199 ("\\possible interpretation: predefined & #", 2200 Spec, Formal_Spec); 2201 else 2202 Error_Msg_NE 2203 ("\\possible interpretation: & defined #", Spec, Formal_Spec); 2204 end if; 2205 end Interpretation_Error; 2206 2207 --------------------------- 2208 -- Is_Intrinsic_Equality -- 2209 --------------------------- 2210 2211 function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean is 2212 begin 2213 return 2214 Ekind (Subp_Id) = E_Operator 2215 and then Chars (Subp_Id) = Name_Op_Eq 2216 and then Is_Intrinsic_Subprogram (Subp_Id); 2217 end Is_Intrinsic_Equality; 2218 2219 --------------------------- 2220 -- Is_Suitable_Candidate -- 2221 --------------------------- 2222 2223 function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean is 2224 begin 2225 if No (Subp_Id) then 2226 return False; 2227 2228 -- An intrinsic subprogram is never a good candidate. This is an 2229 -- indication of a missing primitive, either defined directly or 2230 -- inherited from a parent tagged type. 2231 2232 elsif Is_Intrinsic_Subprogram (Subp_Id) then 2233 return False; 2234 2235 else 2236 return True; 2237 end if; 2238 end Is_Suitable_Candidate; 2239 2240 -- Local variables 2241 2242 Actual_Typ : Entity_Id := Empty; 2243 -- The actual class-wide type for Formal_Typ 2244 2245 CW_Prim_OK : Boolean; 2246 CW_Prim_Op : Entity_Id; 2247 -- The class-wide subprogram (if available) which corresponds to the 2248 -- renamed generic formal subprogram. 2249 2250 Formal_Typ : Entity_Id := Empty; 2251 -- The generic formal type with unknown discriminants 2252 2253 Root_Prim_OK : Boolean; 2254 Root_Prim_Op : Entity_Id; 2255 -- The root type primitive (if available) which corresponds to the 2256 -- renamed generic formal subprogram. 2257 2258 Root_Typ : Entity_Id := Empty; 2259 -- The root type of Actual_Typ 2260 2261 Body_Decl : Node_Id; 2262 Formal : Node_Id; 2263 Prim_Op : Entity_Id; 2264 Spec_Decl : Node_Id; 2265 New_Spec : Node_Id; 2266 2267 -- Start of processing for Build_Class_Wide_Wrapper 2268 2269 begin 2270 -- Analyze the specification of the renaming in case the generation 2271 -- of the class-wide wrapper fails. 2272 2273 Ren_Id := Analyze_Subprogram_Specification (Spec); 2274 Wrap_Id := Any_Id; 2275 2276 -- Do not attempt to build a wrapper if the renaming is in error 2277 2278 if Error_Posted (Nam) then 2279 return; 2280 end if; 2281 2282 -- Analyze the renamed name, but do not resolve it. The resolution is 2283 -- completed once a suitable subprogram is found. 2284 2285 Analyze (Nam); 2286 2287 -- When the renamed name denotes the intrinsic operator equals, the 2288 -- name must be treated as overloaded. This allows for a potential 2289 -- match against the root type's predefined equality function. 2290 2291 if Is_Intrinsic_Equality (Entity (Nam)) then 2292 Set_Is_Overloaded (Nam); 2293 Collect_Interps (Nam); 2294 end if; 2295 2296 -- Step 1: Find the generic formal type with unknown discriminants 2297 -- and its corresponding class-wide actual type from the renamed 2298 -- generic formal subprogram. 2299 2300 Formal := First_Formal (Formal_Spec); 2301 while Present (Formal) loop 2302 if Has_Unknown_Discriminants (Etype (Formal)) 2303 and then not Is_Class_Wide_Type (Etype (Formal)) 2304 and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) 2305 then 2306 Formal_Typ := Etype (Formal); 2307 Actual_Typ := Get_Instance_Of (Formal_Typ); 2308 Root_Typ := Etype (Actual_Typ); 2309 exit; 2310 end if; 2311 2312 Next_Formal (Formal); 2313 end loop; 2314 2315 -- The specification of the generic formal subprogram should always 2316 -- contain a formal type with unknown discriminants whose actual is 2317 -- a class-wide type, otherwise this indicates a failure in routine 2318 -- Has_Class_Wide_Actual. 2319 2320 pragma Assert (Present (Formal_Typ)); 2321 2322 -- Step 2: Find the proper class-wide subprogram or primitive which 2323 -- corresponds to the renamed generic formal subprogram. 2324 2325 CW_Prim_Op := Find_Primitive (Actual_Typ); 2326 CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); 2327 Root_Prim_Op := Find_Primitive (Root_Typ); 2328 Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); 2329 2330 -- The class-wide actual type has two subprograms which correspond to 2331 -- the renamed generic formal subprogram: 2332 2333 -- with procedure Prim_Op (Param : Formal_Typ); 2334 2335 -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited 2336 -- procedure Prim_Op (Param : Actual_Typ'Class); 2337 2338 -- Even though the declaration of the two subprograms is legal, a 2339 -- call to either one is ambiguous and therefore illegal. 2340 2341 if CW_Prim_OK and Root_Prim_OK then 2342 2343 -- A user-defined primitive has precedence over a predefined one 2344 2345 if Is_Internal (CW_Prim_Op) 2346 and then not Is_Internal (Root_Prim_Op) 2347 then 2348 Prim_Op := Root_Prim_Op; 2349 2350 elsif Is_Internal (Root_Prim_Op) 2351 and then not Is_Internal (CW_Prim_Op) 2352 then 2353 Prim_Op := CW_Prim_Op; 2354 2355 elsif CW_Prim_Op = Root_Prim_Op then 2356 Prim_Op := Root_Prim_Op; 2357 2358 -- Otherwise both candidate subprograms are user-defined and 2359 -- ambiguous. 2360 2361 else 2362 Error_Msg_NE 2363 ("ambiguous actual for generic subprogram &", 2364 Spec, Formal_Spec); 2365 Interpretation_Error (Root_Prim_Op); 2366 Interpretation_Error (CW_Prim_Op); 2367 return; 2368 end if; 2369 2370 elsif CW_Prim_OK and not Root_Prim_OK then 2371 Prim_Op := CW_Prim_Op; 2372 2373 elsif not CW_Prim_OK and Root_Prim_OK then 2374 Prim_Op := Root_Prim_Op; 2375 2376 -- An intrinsic equality may act as a suitable candidate in the case 2377 -- of a null type extension where the parent's equality is hidden. A 2378 -- call to an intrinsic equality is expanded as dispatching. 2379 2380 elsif Present (Root_Prim_Op) 2381 and then Is_Intrinsic_Equality (Root_Prim_Op) 2382 then 2383 Prim_Op := Root_Prim_Op; 2384 2385 -- Otherwise there are no candidate subprograms. Let the caller 2386 -- diagnose the error. 2387 2388 else 2389 return; 2390 end if; 2391 2392 -- At this point resolution has taken place and the name is no longer 2393 -- overloaded. Mark the primitive as referenced. 2394 2395 Set_Is_Overloaded (Name (N), False); 2396 Set_Referenced (Prim_Op); 2397 2398 -- Do not generate a wrapper when the only candidate is a class-wide 2399 -- subprogram. Instead modify the renaming to directly map the actual 2400 -- to the generic formal. 2401 2402 if CW_Prim_OK and then Prim_Op = CW_Prim_Op then 2403 Wrap_Id := Prim_Op; 2404 Rewrite (Nam, New_Occurrence_Of (Prim_Op, Loc)); 2405 return; 2406 end if; 2407 2408 -- Step 3: Create the declaration and the body of the wrapper, insert 2409 -- all the pieces into the tree. 2410 2411 -- In GNATprove mode, create a function wrapper in the form of an 2412 -- expression function, so that an implicit postcondition relating 2413 -- the result of calling the wrapper function and the result of the 2414 -- dispatching call to the wrapped function is known during proof. 2415 2416 if GNATprove_Mode 2417 and then Ekind_In (Ren_Id, E_Function, E_Operator) 2418 then 2419 New_Spec := Build_Spec (Ren_Id); 2420 Body_Decl := 2421 Make_Expression_Function (Loc, 2422 Specification => New_Spec, 2423 Expression => 2424 Build_Expr_Fun_Call 2425 (Subp_Id => Prim_Op, 2426 Params => Parameter_Specifications (New_Spec))); 2427 2428 Wrap_Id := Defining_Entity (Body_Decl); 2429 2430 -- Otherwise, create separate spec and body for the subprogram 2431 2432 else 2433 Spec_Decl := 2434 Make_Subprogram_Declaration (Loc, 2435 Specification => Build_Spec (Ren_Id)); 2436 Insert_Before_And_Analyze (N, Spec_Decl); 2437 2438 Wrap_Id := Defining_Entity (Spec_Decl); 2439 2440 Body_Decl := 2441 Make_Subprogram_Body (Loc, 2442 Specification => Build_Spec (Ren_Id), 2443 Declarations => New_List, 2444 Handled_Statement_Sequence => 2445 Make_Handled_Sequence_Of_Statements (Loc, 2446 Statements => New_List ( 2447 Build_Call 2448 (Subp_Id => Prim_Op, 2449 Params => 2450 Parameter_Specifications 2451 (Specification (Spec_Decl)))))); 2452 2453 Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); 2454 end if; 2455 2456 -- If the operator carries an Eliminated pragma, indicate that the 2457 -- wrapper is also to be eliminated, to prevent spurious error when 2458 -- using gnatelim on programs that include box-initialization of 2459 -- equality operators. 2460 2461 Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op)); 2462 2463 -- In GNATprove mode, insert the body in the tree for analysis 2464 2465 if GNATprove_Mode then 2466 Insert_Before_And_Analyze (N, Body_Decl); 2467 end if; 2468 2469 -- The generated body does not freeze and must be analyzed when the 2470 -- class-wide wrapper is frozen. The body is only needed if expansion 2471 -- is enabled. 2472 2473 if Expander_Active then 2474 Append_Freeze_Action (Wrap_Id, Body_Decl); 2475 end if; 2476 2477 -- Step 4: The subprogram renaming aliases the wrapper 2478 2479 Rewrite (Nam, New_Occurrence_Of (Wrap_Id, Loc)); 2480 end Build_Class_Wide_Wrapper; 2481 2482 -------------------------- 2483 -- Check_Null_Exclusion -- 2484 -------------------------- 2485 2486 procedure Check_Null_Exclusion 2487 (Ren : Entity_Id; 2488 Sub : Entity_Id) 2489 is 2490 Ren_Formal : Entity_Id; 2491 Sub_Formal : Entity_Id; 2492 2493 begin 2494 -- Parameter check 2495 2496 Ren_Formal := First_Formal (Ren); 2497 Sub_Formal := First_Formal (Sub); 2498 while Present (Ren_Formal) and then Present (Sub_Formal) loop 2499 if Has_Null_Exclusion (Parent (Ren_Formal)) 2500 and then 2501 not (Has_Null_Exclusion (Parent (Sub_Formal)) 2502 or else Can_Never_Be_Null (Etype (Sub_Formal))) 2503 then 2504 Error_Msg_NE 2505 ("`NOT NULL` required for parameter &", 2506 Parent (Sub_Formal), Sub_Formal); 2507 end if; 2508 2509 Next_Formal (Ren_Formal); 2510 Next_Formal (Sub_Formal); 2511 end loop; 2512 2513 -- Return profile check 2514 2515 if Nkind (Parent (Ren)) = N_Function_Specification 2516 and then Nkind (Parent (Sub)) = N_Function_Specification 2517 and then Has_Null_Exclusion (Parent (Ren)) 2518 and then not (Has_Null_Exclusion (Parent (Sub)) 2519 or else Can_Never_Be_Null (Etype (Sub))) 2520 then 2521 Error_Msg_N 2522 ("return must specify `NOT NULL`", 2523 Result_Definition (Parent (Sub))); 2524 end if; 2525 end Check_Null_Exclusion; 2526 2527 ------------------------------------- 2528 -- Check_SPARK_Primitive_Operation -- 2529 ------------------------------------- 2530 2531 procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is 2532 Prag : constant Node_Id := SPARK_Pragma (Subp_Id); 2533 Typ : Entity_Id; 2534 2535 begin 2536 -- Nothing to do when the subprogram is not subject to SPARK_Mode On 2537 -- because this check applies to SPARK code only. 2538 2539 if not (Present (Prag) 2540 and then Get_SPARK_Mode_From_Annotation (Prag) = On) 2541 then 2542 return; 2543 2544 -- Nothing to do when the subprogram is not a primitive operation 2545 2546 elsif not Is_Primitive (Subp_Id) then 2547 return; 2548 end if; 2549 2550 Typ := Find_Dispatching_Type (Subp_Id); 2551 2552 -- Nothing to do when the subprogram is a primitive operation of an 2553 -- untagged type. 2554 2555 if No (Typ) then 2556 return; 2557 end if; 2558 2559 -- At this point a renaming declaration introduces a new primitive 2560 -- operation for a tagged type. 2561 2562 Error_Msg_Node_2 := Typ; 2563 Error_Msg_NE 2564 ("subprogram renaming & cannot declare primitive for type & " 2565 & "(SPARK RM 6.1.1(3))", N, Subp_Id); 2566 end Check_SPARK_Primitive_Operation; 2567 2568 --------------------------- 2569 -- Freeze_Actual_Profile -- 2570 --------------------------- 2571 2572 procedure Freeze_Actual_Profile is 2573 F : Entity_Id; 2574 Has_Untagged_Inc : Boolean; 2575 Instantiation_Node : constant Node_Id := Parent (N); 2576 2577 begin 2578 if Ada_Version >= Ada_2012 then 2579 F := First_Formal (Formal_Spec); 2580 Has_Untagged_Inc := False; 2581 while Present (F) loop 2582 if Ekind (Etype (F)) = E_Incomplete_Type 2583 and then not Is_Tagged_Type (Etype (F)) 2584 then 2585 Has_Untagged_Inc := True; 2586 exit; 2587 end if; 2588 2589 F := Next_Formal (F); 2590 end loop; 2591 2592 if Ekind (Formal_Spec) = E_Function 2593 and then not Is_Tagged_Type (Etype (Formal_Spec)) 2594 then 2595 Has_Untagged_Inc := True; 2596 end if; 2597 2598 if not Has_Untagged_Inc then 2599 F := First_Formal (Old_S); 2600 while Present (F) loop 2601 Freeze_Before (Instantiation_Node, Etype (F)); 2602 2603 if Is_Incomplete_Or_Private_Type (Etype (F)) 2604 and then No (Underlying_Type (Etype (F))) 2605 then 2606 -- Exclude generic types, or types derived from them. 2607 -- They will be frozen in the enclosing instance. 2608 2609 if Is_Generic_Type (Etype (F)) 2610 or else Is_Generic_Type (Root_Type (Etype (F))) 2611 then 2612 null; 2613 2614 -- A limited view of a type declared elsewhere needs no 2615 -- freezing actions. 2616 2617 elsif From_Limited_With (Etype (F)) then 2618 null; 2619 2620 else 2621 Error_Msg_NE 2622 ("type& must be frozen before this point", 2623 Instantiation_Node, Etype (F)); 2624 end if; 2625 end if; 2626 2627 F := Next_Formal (F); 2628 end loop; 2629 end if; 2630 end if; 2631 end Freeze_Actual_Profile; 2632 2633 --------------------------- 2634 -- Has_Class_Wide_Actual -- 2635 --------------------------- 2636 2637 function Has_Class_Wide_Actual return Boolean is 2638 Formal : Entity_Id; 2639 Formal_Typ : Entity_Id; 2640 2641 begin 2642 if Is_Actual then 2643 Formal := First_Formal (Formal_Spec); 2644 while Present (Formal) loop 2645 Formal_Typ := Etype (Formal); 2646 2647 if Has_Unknown_Discriminants (Formal_Typ) 2648 and then not Is_Class_Wide_Type (Formal_Typ) 2649 and then Is_Class_Wide_Type (Get_Instance_Of (Formal_Typ)) 2650 then 2651 return True; 2652 end if; 2653 2654 Next_Formal (Formal); 2655 end loop; 2656 end if; 2657 2658 return False; 2659 end Has_Class_Wide_Actual; 2660 2661 ------------------------- 2662 -- Original_Subprogram -- 2663 ------------------------- 2664 2665 function Original_Subprogram (Subp : Entity_Id) return Entity_Id is 2666 Orig_Decl : Node_Id; 2667 Orig_Subp : Entity_Id; 2668 2669 begin 2670 -- First case: renamed entity is itself a renaming 2671 2672 if Present (Alias (Subp)) then 2673 return Alias (Subp); 2674 2675 elsif Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration 2676 and then Present (Corresponding_Body (Unit_Declaration_Node (Subp))) 2677 then 2678 -- Check if renamed entity is a renaming_as_body 2679 2680 Orig_Decl := 2681 Unit_Declaration_Node 2682 (Corresponding_Body (Unit_Declaration_Node (Subp))); 2683 2684 if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then 2685 Orig_Subp := Entity (Name (Orig_Decl)); 2686 2687 if Orig_Subp = Rename_Spec then 2688 2689 -- Circularity detected 2690 2691 return Orig_Subp; 2692 2693 else 2694 return (Original_Subprogram (Orig_Subp)); 2695 end if; 2696 else 2697 return Subp; 2698 end if; 2699 else 2700 return Subp; 2701 end if; 2702 end Original_Subprogram; 2703 2704 -- Local variables 2705 2706 CW_Actual : constant Boolean := Has_Class_Wide_Actual; 2707 -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a 2708 -- defaulted formal subprogram when the actual for a related formal 2709 -- type is class-wide. 2710 2711 Inst_Node : Node_Id := Empty; 2712 New_S : Entity_Id; 2713 2714 -- Start of processing for Analyze_Subprogram_Renaming 2715 2716 begin 2717 -- We must test for the attribute renaming case before the Analyze 2718 -- call because otherwise Sem_Attr will complain that the attribute 2719 -- is missing an argument when it is analyzed. 2720 2721 if Nkind (Nam) = N_Attribute_Reference then 2722 2723 -- In the case of an abstract formal subprogram association, rewrite 2724 -- an actual given by a stream attribute as the name of the 2725 -- corresponding stream primitive of the type. 2726 2727 -- In a generic context the stream operations are not generated, and 2728 -- this must be treated as a normal attribute reference, to be 2729 -- expanded in subsequent instantiations. 2730 2731 if Is_Actual 2732 and then Is_Abstract_Subprogram (Formal_Spec) 2733 and then Expander_Active 2734 then 2735 declare 2736 Prefix_Type : constant Entity_Id := Entity (Prefix (Nam)); 2737 Stream_Prim : Entity_Id; 2738 2739 begin 2740 -- The class-wide forms of the stream attributes are not 2741 -- primitive dispatching operations (even though they 2742 -- internally dispatch to a stream attribute). 2743 2744 if Is_Class_Wide_Type (Prefix_Type) then 2745 Error_Msg_N 2746 ("attribute must be a primitive dispatching operation", 2747 Nam); 2748 return; 2749 end if; 2750 2751 -- Retrieve the primitive subprogram associated with the 2752 -- attribute. This can only be a stream attribute, since those 2753 -- are the only ones that are dispatching (and the actual for 2754 -- an abstract formal subprogram must be dispatching 2755 -- operation). 2756 2757 case Attribute_Name (Nam) is 2758 when Name_Input => 2759 Stream_Prim := 2760 Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); 2761 2762 when Name_Output => 2763 Stream_Prim := 2764 Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); 2765 2766 when Name_Read => 2767 Stream_Prim := 2768 Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); 2769 2770 when Name_Write => 2771 Stream_Prim := 2772 Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); 2773 2774 when others => 2775 Error_Msg_N 2776 ("attribute must be a primitive dispatching operation", 2777 Nam); 2778 return; 2779 end case; 2780 2781 -- If no operation was found, and the type is limited, the user 2782 -- should have defined one. 2783 2784 if No (Stream_Prim) then 2785 if Is_Limited_Type (Prefix_Type) then 2786 Error_Msg_NE 2787 ("stream operation not defined for type&", 2788 N, Prefix_Type); 2789 return; 2790 2791 -- Otherwise, compiler should have generated default 2792 2793 else 2794 raise Program_Error; 2795 end if; 2796 end if; 2797 2798 -- Rewrite the attribute into the name of its corresponding 2799 -- primitive dispatching subprogram. We can then proceed with 2800 -- the usual processing for subprogram renamings. 2801 2802 declare 2803 Prim_Name : constant Node_Id := 2804 Make_Identifier (Sloc (Nam), 2805 Chars => Chars (Stream_Prim)); 2806 begin 2807 Set_Entity (Prim_Name, Stream_Prim); 2808 Rewrite (Nam, Prim_Name); 2809 Analyze (Nam); 2810 end; 2811 end; 2812 2813 -- Normal processing for a renaming of an attribute 2814 2815 else 2816 Attribute_Renaming (N); 2817 return; 2818 end if; 2819 end if; 2820 2821 -- Check whether this declaration corresponds to the instantiation of a 2822 -- formal subprogram. 2823 2824 -- If this is an instantiation, the corresponding actual is frozen and 2825 -- error messages can be made more precise. If this is a default 2826 -- subprogram, the entity is already established in the generic, and is 2827 -- not retrieved by visibility. If it is a default with a box, the 2828 -- candidate interpretations, if any, have been collected when building 2829 -- the renaming declaration. If overloaded, the proper interpretation is 2830 -- determined in Find_Renamed_Entity. If the entity is an operator, 2831 -- Find_Renamed_Entity applies additional visibility checks. 2832 2833 if Is_Actual then 2834 Inst_Node := Unit_Declaration_Node (Formal_Spec); 2835 2836 -- Check whether the renaming is for a defaulted actual subprogram 2837 -- with a class-wide actual. 2838 2839 -- The class-wide wrapper is not needed in GNATprove_Mode and there 2840 -- is an external axiomatization on the package. 2841 2842 if CW_Actual 2843 and then Box_Present (Inst_Node) 2844 and then not 2845 (GNATprove_Mode 2846 and then 2847 Present (Containing_Package_With_Ext_Axioms (Formal_Spec))) 2848 then 2849 Build_Class_Wide_Wrapper (New_S, Old_S); 2850 2851 elsif Is_Entity_Name (Nam) 2852 and then Present (Entity (Nam)) 2853 and then not Comes_From_Source (Nam) 2854 and then not Is_Overloaded (Nam) 2855 then 2856 Old_S := Entity (Nam); 2857 2858 -- The subprogram renaming declaration may become Ghost if it 2859 -- renames a Ghost entity. 2860 2861 Mark_Ghost_Renaming (N, Old_S); 2862 2863 New_S := Analyze_Subprogram_Specification (Spec); 2864 2865 -- Operator case 2866 2867 if Ekind (Old_S) = E_Operator then 2868 2869 -- Box present 2870 2871 if Box_Present (Inst_Node) then 2872 Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); 2873 2874 -- If there is an immediately visible homonym of the operator 2875 -- and the declaration has a default, this is worth a warning 2876 -- because the user probably did not intend to get the pre- 2877 -- defined operator, visible in the generic declaration. To 2878 -- find if there is an intended candidate, analyze the renaming 2879 -- again in the current context. 2880 2881 elsif Scope (Old_S) = Standard_Standard 2882 and then Present (Default_Name (Inst_Node)) 2883 then 2884 declare 2885 Decl : constant Node_Id := New_Copy_Tree (N); 2886 Hidden : Entity_Id; 2887 2888 begin 2889 Set_Entity (Name (Decl), Empty); 2890 Analyze (Name (Decl)); 2891 Hidden := 2892 Find_Renamed_Entity (Decl, Name (Decl), New_S, True); 2893 2894 if Present (Hidden) 2895 and then In_Open_Scopes (Scope (Hidden)) 2896 and then Is_Immediately_Visible (Hidden) 2897 and then Comes_From_Source (Hidden) 2898 and then Hidden /= Old_S 2899 then 2900 Error_Msg_Sloc := Sloc (Hidden); 2901 Error_Msg_N 2902 ("default subprogram is resolved in the generic " 2903 & "declaration (RM 12.6(17))??", N); 2904 Error_Msg_NE ("\and will not use & #??", N, Hidden); 2905 end if; 2906 end; 2907 end if; 2908 end if; 2909 2910 else 2911 Analyze (Nam); 2912 2913 -- The subprogram renaming declaration may become Ghost if it 2914 -- renames a Ghost entity. 2915 2916 if Is_Entity_Name (Nam) then 2917 Mark_Ghost_Renaming (N, Entity (Nam)); 2918 end if; 2919 2920 New_S := Analyze_Subprogram_Specification (Spec); 2921 end if; 2922 2923 else 2924 -- Renamed entity must be analyzed first, to avoid being hidden by 2925 -- new name (which might be the same in a generic instance). 2926 2927 Analyze (Nam); 2928 2929 -- The subprogram renaming declaration may become Ghost if it renames 2930 -- a Ghost entity. 2931 2932 if Is_Entity_Name (Nam) then 2933 Mark_Ghost_Renaming (N, Entity (Nam)); 2934 end if; 2935 2936 -- The renaming defines a new overloaded entity, which is analyzed 2937 -- like a subprogram declaration. 2938 2939 New_S := Analyze_Subprogram_Specification (Spec); 2940 end if; 2941 2942 if Current_Scope /= Standard_Standard then 2943 Set_Is_Pure (New_S, Is_Pure (Current_Scope)); 2944 end if; 2945 2946 -- Set SPARK mode from current context 2947 2948 Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma); 2949 Set_SPARK_Pragma_Inherited (New_S); 2950 2951 Rename_Spec := Find_Corresponding_Spec (N); 2952 2953 -- Case of Renaming_As_Body 2954 2955 if Present (Rename_Spec) then 2956 Check_Previous_Null_Procedure (N, Rename_Spec); 2957 2958 -- Renaming declaration is the completion of the declaration of 2959 -- Rename_Spec. We build an actual body for it at the freezing point. 2960 2961 Set_Corresponding_Spec (N, Rename_Spec); 2962 2963 -- Deal with special case of stream functions of abstract types 2964 -- and interfaces. 2965 2966 if Nkind (Unit_Declaration_Node (Rename_Spec)) = 2967 N_Abstract_Subprogram_Declaration 2968 then 2969 -- Input stream functions are abstract if the object type is 2970 -- abstract. Similarly, all default stream functions for an 2971 -- interface type are abstract. However, these subprograms may 2972 -- receive explicit declarations in representation clauses, making 2973 -- the attribute subprograms usable as defaults in subsequent 2974 -- type extensions. 2975 -- In this case we rewrite the declaration to make the subprogram 2976 -- non-abstract. We remove the previous declaration, and insert 2977 -- the new one at the point of the renaming, to prevent premature 2978 -- access to unfrozen types. The new declaration reuses the 2979 -- specification of the previous one, and must not be analyzed. 2980 2981 pragma Assert 2982 (Is_Primitive (Entity (Nam)) 2983 and then 2984 Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); 2985 declare 2986 Old_Decl : constant Node_Id := 2987 Unit_Declaration_Node (Rename_Spec); 2988 New_Decl : constant Node_Id := 2989 Make_Subprogram_Declaration (Sloc (N), 2990 Specification => 2991 Relocate_Node (Specification (Old_Decl))); 2992 begin 2993 Remove (Old_Decl); 2994 Insert_After (N, New_Decl); 2995 Set_Is_Abstract_Subprogram (Rename_Spec, False); 2996 Set_Analyzed (New_Decl); 2997 end; 2998 end if; 2999 3000 Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S); 3001 3002 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3003 Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N); 3004 end if; 3005 3006 Set_Convention (New_S, Convention (Rename_Spec)); 3007 Check_Fully_Conformant (New_S, Rename_Spec); 3008 Set_Public_Status (New_S); 3009 3010 if No_Return (Rename_Spec) 3011 and then not No_Return (Entity (Nam)) 3012 then 3013 Error_Msg_N ("renaming completes a No_Return procedure", N); 3014 Error_Msg_N 3015 ("\renamed procedure must be nonreturning (RM 6.5.1 (7/2))", N); 3016 end if; 3017 3018 -- The specification does not introduce new formals, but only 3019 -- repeats the formals of the original subprogram declaration. 3020 -- For cross-reference purposes, and for refactoring tools, we 3021 -- treat the formals of the renaming declaration as body formals. 3022 3023 Reference_Body_Formals (Rename_Spec, New_S); 3024 3025 -- Indicate that the entity in the declaration functions like the 3026 -- corresponding body, and is not a new entity. The body will be 3027 -- constructed later at the freeze point, so indicate that the 3028 -- completion has not been seen yet. 3029 3030 Set_Ekind (New_S, E_Subprogram_Body); 3031 New_S := Rename_Spec; 3032 Set_Has_Completion (Rename_Spec, False); 3033 3034 -- Ada 2005: check overriding indicator 3035 3036 if Present (Overridden_Operation (Rename_Spec)) then 3037 if Must_Not_Override (Specification (N)) then 3038 Error_Msg_NE 3039 ("subprogram& overrides inherited operation", 3040 N, Rename_Spec); 3041 3042 elsif Style_Check 3043 and then not Must_Override (Specification (N)) 3044 then 3045 Style.Missing_Overriding (N, Rename_Spec); 3046 end if; 3047 3048 elsif Must_Override (Specification (N)) then 3049 Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); 3050 end if; 3051 3052 -- Normal subprogram renaming (not renaming as body) 3053 3054 else 3055 Generate_Definition (New_S); 3056 New_Overloaded_Entity (New_S); 3057 3058 if not (Is_Entity_Name (Nam) 3059 and then Is_Intrinsic_Subprogram (Entity (Nam))) 3060 then 3061 Check_Delayed_Subprogram (New_S); 3062 end if; 3063 3064 -- Verify that a SPARK renaming does not declare a primitive 3065 -- operation of a tagged type. 3066 3067 Check_SPARK_Primitive_Operation (New_S); 3068 end if; 3069 3070 -- There is no need for elaboration checks on the new entity, which may 3071 -- be called before the next freezing point where the body will appear. 3072 -- Elaboration checks refer to the real entity, not the one created by 3073 -- the renaming declaration. 3074 3075 Set_Kill_Elaboration_Checks (New_S, True); 3076 3077 -- If we had a previous error, indicate a completely is present to stop 3078 -- junk cascaded messages, but don't take any further action. 3079 3080 if Etype (Nam) = Any_Type then 3081 Set_Has_Completion (New_S); 3082 return; 3083 3084 -- Case where name has the form of a selected component 3085 3086 elsif Nkind (Nam) = N_Selected_Component then 3087 3088 -- A name which has the form A.B can designate an entry of task A, a 3089 -- protected operation of protected object A, or finally a primitive 3090 -- operation of object A. In the later case, A is an object of some 3091 -- tagged type, or an access type that denotes one such. To further 3092 -- distinguish these cases, note that the scope of a task entry or 3093 -- protected operation is type of the prefix. 3094 3095 -- The prefix could be an overloaded function call that returns both 3096 -- kinds of operations. This overloading pathology is left to the 3097 -- dedicated reader ??? 3098 3099 declare 3100 T : constant Entity_Id := Etype (Prefix (Nam)); 3101 3102 begin 3103 if Present (T) 3104 and then 3105 (Is_Tagged_Type (T) 3106 or else 3107 (Is_Access_Type (T) 3108 and then Is_Tagged_Type (Designated_Type (T)))) 3109 and then Scope (Entity (Selector_Name (Nam))) /= T 3110 then 3111 Analyze_Renamed_Primitive_Operation 3112 (N, New_S, Present (Rename_Spec)); 3113 return; 3114 3115 else 3116 -- Renamed entity is an entry or protected operation. For those 3117 -- cases an explicit body is built (at the point of freezing of 3118 -- this entity) that contains a call to the renamed entity. 3119 3120 -- This is not allowed for renaming as body if the renamed 3121 -- spec is already frozen (see RM 8.5.4(5) for details). 3122 3123 if Present (Rename_Spec) and then Is_Frozen (Rename_Spec) then 3124 Error_Msg_N 3125 ("renaming-as-body cannot rename entry as subprogram", N); 3126 Error_Msg_NE 3127 ("\since & is already frozen (RM 8.5.4(5))", 3128 N, Rename_Spec); 3129 else 3130 Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec)); 3131 end if; 3132 3133 return; 3134 end if; 3135 end; 3136 3137 -- Case where name is an explicit dereference X.all 3138 3139 elsif Nkind (Nam) = N_Explicit_Dereference then 3140 3141 -- Renamed entity is designated by access_to_subprogram expression. 3142 -- Must build body to encapsulate call, as in the entry case. 3143 3144 Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec)); 3145 return; 3146 3147 -- Indexed component 3148 3149 elsif Nkind (Nam) = N_Indexed_Component then 3150 Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec)); 3151 return; 3152 3153 -- Character literal 3154 3155 elsif Nkind (Nam) = N_Character_Literal then 3156 Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); 3157 return; 3158 3159 -- Only remaining case is where we have a non-entity name, or a renaming 3160 -- of some other non-overloadable entity. 3161 3162 elsif not Is_Entity_Name (Nam) 3163 or else not Is_Overloadable (Entity (Nam)) 3164 then 3165 -- Do not mention the renaming if it comes from an instance 3166 3167 if not Is_Actual then 3168 Error_Msg_N ("expect valid subprogram name in renaming", N); 3169 else 3170 Error_Msg_NE ("no visible subprogram for formal&", N, Nam); 3171 end if; 3172 3173 return; 3174 end if; 3175 3176 -- Find the renamed entity that matches the given specification. Disable 3177 -- Ada_83 because there is no requirement of full conformance between 3178 -- renamed entity and new entity, even though the same circuit is used. 3179 3180 -- This is a bit of an odd case, which introduces a really irregular use 3181 -- of Ada_Version[_Explicit]. Would be nice to find cleaner way to do 3182 -- this. ??? 3183 3184 Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95); 3185 Ada_Version_Pragma := Empty; 3186 Ada_Version_Explicit := Ada_Version; 3187 3188 if No (Old_S) then 3189 Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); 3190 3191 -- The visible operation may be an inherited abstract operation that 3192 -- was overridden in the private part, in which case a call will 3193 -- dispatch to the overriding operation. Use the overriding one in 3194 -- the renaming declaration, to prevent spurious errors below. 3195 3196 if Is_Overloadable (Old_S) 3197 and then Is_Abstract_Subprogram (Old_S) 3198 and then No (DTC_Entity (Old_S)) 3199 and then Present (Alias (Old_S)) 3200 and then not Is_Abstract_Subprogram (Alias (Old_S)) 3201 and then Present (Overridden_Operation (Alias (Old_S))) 3202 then 3203 Old_S := Alias (Old_S); 3204 end if; 3205 3206 -- When the renamed subprogram is overloaded and used as an actual 3207 -- of a generic, its entity is set to the first available homonym. 3208 -- We must first disambiguate the name, then set the proper entity. 3209 3210 if Is_Actual and then Is_Overloaded (Nam) then 3211 Set_Entity (Nam, Old_S); 3212 end if; 3213 end if; 3214 3215 -- Most common case: subprogram renames subprogram. No body is generated 3216 -- in this case, so we must indicate the declaration is complete as is. 3217 -- and inherit various attributes of the renamed subprogram. 3218 3219 if No (Rename_Spec) then 3220 Set_Has_Completion (New_S); 3221 Set_Is_Imported (New_S, Is_Imported (Entity (Nam))); 3222 Set_Is_Pure (New_S, Is_Pure (Entity (Nam))); 3223 Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam))); 3224 3225 -- Ada 2005 (AI-423): Check the consistency of null exclusions 3226 -- between a subprogram and its correct renaming. 3227 3228 -- Note: the Any_Id check is a guard that prevents compiler crashes 3229 -- when performing a null exclusion check between a renaming and a 3230 -- renamed subprogram that has been found to be illegal. 3231 3232 if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then 3233 Check_Null_Exclusion 3234 (Ren => New_S, 3235 Sub => Entity (Nam)); 3236 end if; 3237 3238 -- Enforce the Ada 2005 rule that the renamed entity cannot require 3239 -- overriding. The flag Requires_Overriding is set very selectively 3240 -- and misses some other illegal cases. The additional conditions 3241 -- checked below are sufficient but not necessary ??? 3242 3243 -- The rule does not apply to the renaming generated for an actual 3244 -- subprogram in an instance. 3245 3246 if Is_Actual then 3247 null; 3248 3249 -- Guard against previous errors, and omit renamings of predefined 3250 -- operators. 3251 3252 elsif not Ekind_In (Old_S, E_Function, E_Procedure) then 3253 null; 3254 3255 elsif Requires_Overriding (Old_S) 3256 or else 3257 (Is_Abstract_Subprogram (Old_S) 3258 and then Present (Find_Dispatching_Type (Old_S)) 3259 and then not Is_Abstract_Type (Find_Dispatching_Type (Old_S))) 3260 then 3261 Error_Msg_N 3262 ("renamed entity cannot be subprogram that requires overriding " 3263 & "(RM 8.5.4 (5.1))", N); 3264 end if; 3265 3266 declare 3267 Prev : constant Entity_Id := Overridden_Operation (New_S); 3268 begin 3269 if Present (Prev) 3270 and then 3271 (Has_Non_Trivial_Precondition (Prev) 3272 or else Has_Non_Trivial_Precondition (Old_S)) 3273 then 3274 Error_Msg_NE 3275 ("conflicting inherited classwide preconditions in renaming " 3276 & "of& (RM 6.1.1 (17)", N, Old_S); 3277 end if; 3278 end; 3279 end if; 3280 3281 if Old_S /= Any_Id then 3282 if Is_Actual and then From_Default (N) then 3283 3284 -- This is an implicit reference to the default actual 3285 3286 Generate_Reference (Old_S, Nam, Typ => 'i', Force => True); 3287 3288 else 3289 Generate_Reference (Old_S, Nam); 3290 end if; 3291 3292 Check_Internal_Protected_Use (N, Old_S); 3293 3294 -- For a renaming-as-body, require subtype conformance, but if the 3295 -- declaration being completed has not been frozen, then inherit the 3296 -- convention of the renamed subprogram prior to checking conformance 3297 -- (unless the renaming has an explicit convention established; the 3298 -- rule stated in the RM doesn't seem to address this ???). 3299 3300 if Present (Rename_Spec) then 3301 Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b'); 3302 Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec); 3303 3304 if not Is_Frozen (Rename_Spec) then 3305 if not Has_Convention_Pragma (Rename_Spec) then 3306 Set_Convention (New_S, Convention (Old_S)); 3307 end if; 3308 3309 if Ekind (Old_S) /= E_Operator then 3310 Check_Mode_Conformant (New_S, Old_S, Spec); 3311 end if; 3312 3313 if Original_Subprogram (Old_S) = Rename_Spec then 3314 Error_Msg_N ("unfrozen subprogram cannot rename itself ", N); 3315 end if; 3316 else 3317 Check_Subtype_Conformant (New_S, Old_S, Spec); 3318 end if; 3319 3320 Check_Frozen_Renaming (N, Rename_Spec); 3321 3322 -- Check explicitly that renamed entity is not intrinsic, because 3323 -- in a generic the renamed body is not built. In this case, 3324 -- the renaming_as_body is a completion. 3325 3326 if Inside_A_Generic then 3327 if Is_Frozen (Rename_Spec) 3328 and then Is_Intrinsic_Subprogram (Old_S) 3329 then 3330 Error_Msg_N 3331 ("subprogram in renaming_as_body cannot be intrinsic", 3332 Name (N)); 3333 end if; 3334 3335 Set_Has_Completion (Rename_Spec); 3336 end if; 3337 3338 elsif Ekind (Old_S) /= E_Operator then 3339 3340 -- If this a defaulted subprogram for a class-wide actual there is 3341 -- no check for mode conformance, given that the signatures don't 3342 -- match (the source mentions T but the actual mentions T'Class). 3343 3344 if CW_Actual then 3345 null; 3346 elsif not Is_Actual or else No (Enclosing_Instance) then 3347 Check_Mode_Conformant (New_S, Old_S); 3348 end if; 3349 3350 if Is_Actual and then Error_Posted (New_S) then 3351 Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); 3352 end if; 3353 end if; 3354 3355 if No (Rename_Spec) then 3356 3357 -- The parameter profile of the new entity is that of the renamed 3358 -- entity: the subtypes given in the specification are irrelevant. 3359 3360 Inherit_Renamed_Profile (New_S, Old_S); 3361 3362 -- A call to the subprogram is transformed into a call to the 3363 -- renamed entity. This is transitive if the renamed entity is 3364 -- itself a renaming. 3365 3366 if Present (Alias (Old_S)) then 3367 Set_Alias (New_S, Alias (Old_S)); 3368 else 3369 Set_Alias (New_S, Old_S); 3370 end if; 3371 3372 -- Note that we do not set Is_Intrinsic_Subprogram if we have a 3373 -- renaming as body, since the entity in this case is not an 3374 -- intrinsic (it calls an intrinsic, but we have a real body for 3375 -- this call, and it is in this body that the required intrinsic 3376 -- processing will take place). 3377 3378 -- Also, if this is a renaming of inequality, the renamed operator 3379 -- is intrinsic, but what matters is the corresponding equality 3380 -- operator, which may be user-defined. 3381 3382 Set_Is_Intrinsic_Subprogram 3383 (New_S, 3384 Is_Intrinsic_Subprogram (Old_S) 3385 and then 3386 (Chars (Old_S) /= Name_Op_Ne 3387 or else Ekind (Old_S) = E_Operator 3388 or else Is_Intrinsic_Subprogram 3389 (Corresponding_Equality (Old_S)))); 3390 3391 if Ekind (Alias (New_S)) = E_Operator then 3392 Set_Has_Delayed_Freeze (New_S, False); 3393 end if; 3394 3395 -- If the renaming corresponds to an association for an abstract 3396 -- formal subprogram, then various attributes must be set to 3397 -- indicate that the renaming is an abstract dispatching operation 3398 -- with a controlling type. 3399 3400 if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then 3401 3402 -- Mark the renaming as abstract here, so Find_Dispatching_Type 3403 -- see it as corresponding to a generic association for a 3404 -- formal abstract subprogram 3405 3406 Set_Is_Abstract_Subprogram (New_S); 3407 3408 declare 3409 New_S_Ctrl_Type : constant Entity_Id := 3410 Find_Dispatching_Type (New_S); 3411 Old_S_Ctrl_Type : constant Entity_Id := 3412 Find_Dispatching_Type (Old_S); 3413 3414 begin 3415 3416 -- The actual must match the (instance of the) formal, 3417 -- and must be a controlling type. 3418 3419 if Old_S_Ctrl_Type /= New_S_Ctrl_Type 3420 or else No (New_S_Ctrl_Type) 3421 then 3422 Error_Msg_NE 3423 ("actual must be dispatching subprogram for type&", 3424 Nam, New_S_Ctrl_Type); 3425 3426 else 3427 Set_Is_Dispatching_Operation (New_S); 3428 Check_Controlling_Formals (New_S_Ctrl_Type, New_S); 3429 3430 -- If the actual in the formal subprogram is itself a 3431 -- formal abstract subprogram association, there's no 3432 -- dispatch table component or position to inherit. 3433 3434 if Present (DTC_Entity (Old_S)) then 3435 Set_DTC_Entity (New_S, DTC_Entity (Old_S)); 3436 Set_DT_Position_Value (New_S, DT_Position (Old_S)); 3437 end if; 3438 end if; 3439 end; 3440 end if; 3441 end if; 3442 3443 if Is_Actual then 3444 null; 3445 3446 -- The following is illegal, because F hides whatever other F may 3447 -- be around: 3448 -- function F (...) renames F; 3449 3450 elsif Old_S = New_S 3451 or else (Nkind (Nam) /= N_Expanded_Name 3452 and then Chars (Old_S) = Chars (New_S)) 3453 then 3454 Error_Msg_N ("subprogram cannot rename itself", N); 3455 3456 -- This is illegal even if we use a selector: 3457 -- function F (...) renames Pkg.F; 3458 -- because F is still hidden. 3459 3460 elsif Nkind (Nam) = N_Expanded_Name 3461 and then Entity (Prefix (Nam)) = Current_Scope 3462 and then Chars (Selector_Name (Nam)) = Chars (New_S) 3463 then 3464 -- This is an error, but we overlook the error and accept the 3465 -- renaming if the special Overriding_Renamings mode is in effect. 3466 3467 if not Overriding_Renamings then 3468 Error_Msg_NE 3469 ("implicit operation& is not visible (RM 8.3 (15))", 3470 Nam, Old_S); 3471 end if; 3472 end if; 3473 3474 Set_Convention (New_S, Convention (Old_S)); 3475 3476 if Is_Abstract_Subprogram (Old_S) then 3477 if Present (Rename_Spec) then 3478 Error_Msg_N 3479 ("a renaming-as-body cannot rename an abstract subprogram", 3480 N); 3481 Set_Has_Completion (Rename_Spec); 3482 else 3483 Set_Is_Abstract_Subprogram (New_S); 3484 end if; 3485 end if; 3486 3487 Check_Library_Unit_Renaming (N, Old_S); 3488 3489 -- Pathological case: procedure renames entry in the scope of its 3490 -- task. Entry is given by simple name, but body must be built for 3491 -- procedure. Of course if called it will deadlock. 3492 3493 if Ekind (Old_S) = E_Entry then 3494 Set_Has_Completion (New_S, False); 3495 Set_Alias (New_S, Empty); 3496 end if; 3497 3498 -- Do not freeze the renaming nor the renamed entity when the context 3499 -- is an enclosing generic. Freezing is an expansion activity, and in 3500 -- addition the renamed entity may depend on the generic formals of 3501 -- the enclosing generic. 3502 3503 if Is_Actual and not Inside_A_Generic then 3504 Freeze_Before (N, Old_S); 3505 Freeze_Actual_Profile; 3506 Set_Has_Delayed_Freeze (New_S, False); 3507 Freeze_Before (N, New_S); 3508 3509 -- An abstract subprogram is only allowed as an actual in the case 3510 -- where the formal subprogram is also abstract. 3511 3512 if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) 3513 and then Is_Abstract_Subprogram (Old_S) 3514 and then not Is_Abstract_Subprogram (Formal_Spec) 3515 then 3516 Error_Msg_N 3517 ("abstract subprogram not allowed as generic actual", Nam); 3518 end if; 3519 end if; 3520 3521 else 3522 -- A common error is to assume that implicit operators for types are 3523 -- defined in Standard, or in the scope of a subtype. In those cases 3524 -- where the renamed entity is given with an expanded name, it is 3525 -- worth mentioning that operators for the type are not declared in 3526 -- the scope given by the prefix. 3527 3528 if Nkind (Nam) = N_Expanded_Name 3529 and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol 3530 and then Scope (Entity (Nam)) = Standard_Standard 3531 then 3532 declare 3533 T : constant Entity_Id := 3534 Base_Type (Etype (First_Formal (New_S))); 3535 begin 3536 Error_Msg_Node_2 := Prefix (Nam); 3537 Error_Msg_NE 3538 ("operator for type& is not declared in&", Prefix (Nam), T); 3539 end; 3540 3541 else 3542 Error_Msg_NE 3543 ("no visible subprogram matches the specification for&", 3544 Spec, New_S); 3545 end if; 3546 3547 if Present (Candidate_Renaming) then 3548 declare 3549 F1 : Entity_Id; 3550 F2 : Entity_Id; 3551 T1 : Entity_Id; 3552 3553 begin 3554 F1 := First_Formal (Candidate_Renaming); 3555 F2 := First_Formal (New_S); 3556 T1 := First_Subtype (Etype (F1)); 3557 while Present (F1) and then Present (F2) loop 3558 Next_Formal (F1); 3559 Next_Formal (F2); 3560 end loop; 3561 3562 if Present (F1) and then Present (Default_Value (F1)) then 3563 if Present (Next_Formal (F1)) then 3564 Error_Msg_NE 3565 ("\missing specification for & and other formals with " 3566 & "defaults", Spec, F1); 3567 else 3568 Error_Msg_NE ("\missing specification for &", Spec, F1); 3569 end if; 3570 end if; 3571 3572 if Nkind (Nam) = N_Operator_Symbol 3573 and then From_Default (N) 3574 then 3575 Error_Msg_Node_2 := T1; 3576 Error_Msg_NE 3577 ("default & on & is not directly visible", Nam, Nam); 3578 end if; 3579 end; 3580 end if; 3581 end if; 3582 3583 -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that 3584 -- controlling access parameters are known non-null for the renamed 3585 -- subprogram. Test also applies to a subprogram instantiation that 3586 -- is dispatching. Test is skipped if some previous error was detected 3587 -- that set Old_S to Any_Id. 3588 3589 if Ada_Version >= Ada_2005 3590 and then Old_S /= Any_Id 3591 and then not Is_Dispatching_Operation (Old_S) 3592 and then Is_Dispatching_Operation (New_S) 3593 then 3594 declare 3595 Old_F : Entity_Id; 3596 New_F : Entity_Id; 3597 3598 begin 3599 Old_F := First_Formal (Old_S); 3600 New_F := First_Formal (New_S); 3601 while Present (Old_F) loop 3602 if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type 3603 and then Is_Controlling_Formal (New_F) 3604 and then not Can_Never_Be_Null (Old_F) 3605 then 3606 Error_Msg_N ("access parameter is controlling,", New_F); 3607 Error_Msg_NE 3608 ("\corresponding parameter of& must be explicitly null " 3609 & "excluding", New_F, Old_S); 3610 end if; 3611 3612 Next_Formal (Old_F); 3613 Next_Formal (New_F); 3614 end loop; 3615 end; 3616 end if; 3617 3618 -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005) 3619 -- is to warn if an operator is being renamed as a different operator. 3620 -- If the operator is predefined, examine the kind of the entity, not 3621 -- the abbreviated declaration in Standard. 3622 3623 if Comes_From_Source (N) 3624 and then Present (Old_S) 3625 and then (Nkind (Old_S) = N_Defining_Operator_Symbol 3626 or else Ekind (Old_S) = E_Operator) 3627 and then Nkind (New_S) = N_Defining_Operator_Symbol 3628 and then Chars (Old_S) /= Chars (New_S) 3629 then 3630 Error_Msg_NE 3631 ("& is being renamed as a different operator??", N, Old_S); 3632 end if; 3633 3634 -- Check for renaming of obsolescent subprogram 3635 3636 Check_Obsolescent_2005_Entity (Entity (Nam), Nam); 3637 3638 -- Another warning or some utility: if the new subprogram as the same 3639 -- name as the old one, the old one is not hidden by an outer homograph, 3640 -- the new one is not a public symbol, and the old one is otherwise 3641 -- directly visible, the renaming is superfluous. 3642 3643 if Chars (Old_S) = Chars (New_S) 3644 and then Comes_From_Source (N) 3645 and then Scope (Old_S) /= Standard_Standard 3646 and then Warn_On_Redundant_Constructs 3647 and then (Is_Immediately_Visible (Old_S) 3648 or else Is_Potentially_Use_Visible (Old_S)) 3649 and then Is_Overloadable (Current_Scope) 3650 and then Chars (Current_Scope) /= Chars (Old_S) 3651 then 3652 Error_Msg_N 3653 ("redundant renaming, entity is directly visible?r?", Name (N)); 3654 end if; 3655 3656 -- Implementation-defined aspect specifications can appear in a renaming 3657 -- declaration, but not language-defined ones. The call to procedure 3658 -- Analyze_Aspect_Specifications will take care of this error check. 3659 3660 if Has_Aspects (N) then 3661 Analyze_Aspect_Specifications (N, New_S); 3662 end if; 3663 3664 Ada_Version := Save_AV; 3665 Ada_Version_Pragma := Save_AVP; 3666 Ada_Version_Explicit := Save_AV_Exp; 3667 3668 -- In GNATprove mode, the renamings of actual subprograms are replaced 3669 -- with wrapper functions that make it easier to propagate axioms to the 3670 -- points of call within an instance. Wrappers are generated if formal 3671 -- subprogram is subject to axiomatization. 3672 3673 -- The types in the wrapper profiles are obtained from (instances of) 3674 -- the types of the formal subprogram. 3675 3676 if Is_Actual 3677 and then GNATprove_Mode 3678 and then Present (Containing_Package_With_Ext_Axioms (Formal_Spec)) 3679 and then not Inside_A_Generic 3680 then 3681 if Ekind (Old_S) = E_Function then 3682 Rewrite (N, Build_Function_Wrapper (Formal_Spec, Old_S)); 3683 Analyze (N); 3684 3685 elsif Ekind (Old_S) = E_Operator then 3686 Rewrite (N, Build_Operator_Wrapper (Formal_Spec, Old_S)); 3687 Analyze (N); 3688 end if; 3689 end if; 3690 3691 -- Check if we are looking at an Ada 2012 defaulted formal subprogram 3692 -- and mark any use_package_clauses that affect the visibility of the 3693 -- implicit generic actual. 3694 3695 if Is_Generic_Actual_Subprogram (New_S) 3696 and then (Is_Intrinsic_Subprogram (New_S) or else From_Default (N)) 3697 then 3698 Mark_Use_Clauses (New_S); 3699 3700 -- Handle overloaded subprograms 3701 3702 if Present (Alias (New_S)) then 3703 Mark_Use_Clauses (Alias (New_S)); 3704 end if; 3705 end if; 3706 end Analyze_Subprogram_Renaming; 3707 3708 ------------------------- 3709 -- Analyze_Use_Package -- 3710 ------------------------- 3711 3712 -- Resolve the package names in the use clause, and make all the visible 3713 -- entities defined in the package potentially use-visible. If the package 3714 -- is already in use from a previous use clause, its visible entities are 3715 -- already use-visible. In that case, mark the occurrence as a redundant 3716 -- use. If the package is an open scope, i.e. if the use clause occurs 3717 -- within the package itself, ignore it. 3718 3719 procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is 3720 procedure Analyze_Package_Name (Clause : Node_Id); 3721 -- Perform analysis on a package name from a use_package_clause 3722 3723 procedure Analyze_Package_Name_List (Head_Clause : Node_Id); 3724 -- Similar to Analyze_Package_Name but iterates over all the names 3725 -- in a use clause. 3726 3727 -------------------------- 3728 -- Analyze_Package_Name -- 3729 -------------------------- 3730 3731 procedure Analyze_Package_Name (Clause : Node_Id) is 3732 Pack : constant Node_Id := Name (Clause); 3733 Pref : Node_Id; 3734 3735 begin 3736 pragma Assert (Nkind (Clause) = N_Use_Package_Clause); 3737 Analyze (Pack); 3738 3739 -- Verify that the package standard is not directly named in a 3740 -- use_package_clause. 3741 3742 if Nkind (Parent (Clause)) = N_Compilation_Unit 3743 and then Nkind (Pack) = N_Expanded_Name 3744 then 3745 Pref := Prefix (Pack); 3746 3747 while Nkind (Pref) = N_Expanded_Name loop 3748 Pref := Prefix (Pref); 3749 end loop; 3750 3751 if Entity (Pref) = Standard_Standard then 3752 Error_Msg_N 3753 ("predefined package Standard cannot appear in a context " 3754 & "clause", Pref); 3755 end if; 3756 end if; 3757 end Analyze_Package_Name; 3758 3759 ------------------------------- 3760 -- Analyze_Package_Name_List -- 3761 ------------------------------- 3762 3763 procedure Analyze_Package_Name_List (Head_Clause : Node_Id) is 3764 Curr : Node_Id; 3765 3766 begin 3767 -- Due to the way source use clauses are split during parsing we are 3768 -- forced to simply iterate through all entities in scope until the 3769 -- clause representing the last name in the list is found. 3770 3771 Curr := Head_Clause; 3772 while Present (Curr) loop 3773 Analyze_Package_Name (Curr); 3774 3775 -- Stop iterating over the names in the use clause when we are at 3776 -- the last one. 3777 3778 exit when not More_Ids (Curr) and then Prev_Ids (Curr); 3779 Next (Curr); 3780 end loop; 3781 end Analyze_Package_Name_List; 3782 3783 -- Local variables 3784 3785 Ghost_Id : Entity_Id := Empty; 3786 Living_Id : Entity_Id := Empty; 3787 Pack : Entity_Id; 3788 3789 -- Start of processing for Analyze_Use_Package 3790 3791 begin 3792 Check_SPARK_05_Restriction ("use clause is not allowed", N); 3793 3794 Set_Hidden_By_Use_Clause (N, No_Elist); 3795 3796 -- Use clause not allowed in a spec of a predefined package declaration 3797 -- except that packages whose file name starts a-n are OK (these are 3798 -- children of Ada.Numerics, which are never loaded by Rtsfind). 3799 3800 if Is_Predefined_Unit (Current_Sem_Unit) 3801 and then Get_Name_String 3802 (Unit_File_Name (Current_Sem_Unit)) (1 .. 3) /= "a-n" 3803 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 3804 N_Package_Declaration 3805 then 3806 Error_Msg_N ("use clause not allowed in predefined spec", N); 3807 end if; 3808 3809 -- Loop through all package names from the original use clause in 3810 -- order to analyze referenced packages. A use_package_clause with only 3811 -- one name does not have More_Ids or Prev_Ids set, while a clause with 3812 -- More_Ids only starts the chain produced by the parser. 3813 3814 if not More_Ids (N) and then not Prev_Ids (N) then 3815 Analyze_Package_Name (N); 3816 3817 elsif More_Ids (N) and then not Prev_Ids (N) then 3818 Analyze_Package_Name_List (N); 3819 end if; 3820 3821 if not Is_Entity_Name (Name (N)) then 3822 Error_Msg_N ("& is not a package", Name (N)); 3823 3824 return; 3825 end if; 3826 3827 if Chain then 3828 Chain_Use_Clause (N); 3829 end if; 3830 3831 Pack := Entity (Name (N)); 3832 3833 -- There are many cases where scopes are manipulated during analysis, so 3834 -- check that Pack's current use clause has not already been chained 3835 -- before setting its previous use clause. 3836 3837 if Ekind (Pack) = E_Package 3838 and then Present (Current_Use_Clause (Pack)) 3839 and then Current_Use_Clause (Pack) /= N 3840 and then No (Prev_Use_Clause (N)) 3841 and then Prev_Use_Clause (Current_Use_Clause (Pack)) /= N 3842 then 3843 Set_Prev_Use_Clause (N, Current_Use_Clause (Pack)); 3844 end if; 3845 3846 -- Mark all entities as potentially use visible. 3847 3848 if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then 3849 if Ekind (Pack) = E_Generic_Package then 3850 Error_Msg_N -- CODEFIX 3851 ("a generic package is not allowed in a use clause", Name (N)); 3852 3853 elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package) 3854 then 3855 Error_Msg_N -- CODEFIX 3856 ("a generic subprogram is not allowed in a use clause", 3857 Name (N)); 3858 3859 elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then 3860 Error_Msg_N -- CODEFIX 3861 ("a subprogram is not allowed in a use clause", Name (N)); 3862 3863 else 3864 Error_Msg_N ("& is not allowed in a use clause", Name (N)); 3865 end if; 3866 3867 else 3868 if Nkind (Parent (N)) = N_Compilation_Unit then 3869 Check_In_Previous_With_Clause (N, Name (N)); 3870 end if; 3871 3872 Use_One_Package (N, Name (N)); 3873 3874 -- Capture the first Ghost package and the first living package 3875 3876 if Is_Entity_Name (Name (N)) then 3877 Pack := Entity (Name (N)); 3878 3879 if Is_Ghost_Entity (Pack) then 3880 if No (Ghost_Id) then 3881 Ghost_Id := Pack; 3882 end if; 3883 3884 elsif No (Living_Id) then 3885 Living_Id := Pack; 3886 end if; 3887 end if; 3888 end if; 3889 end Analyze_Use_Package; 3890 3891 ---------------------- 3892 -- Analyze_Use_Type -- 3893 ---------------------- 3894 3895 procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True) is 3896 E : Entity_Id; 3897 Id : Node_Id; 3898 3899 begin 3900 Set_Hidden_By_Use_Clause (N, No_Elist); 3901 3902 -- Chain clause to list of use clauses in current scope when flagged 3903 3904 if Chain then 3905 Chain_Use_Clause (N); 3906 end if; 3907 3908 -- Obtain the base type of the type denoted within the use_type_clause's 3909 -- subtype mark. 3910 3911 Id := Subtype_Mark (N); 3912 Find_Type (Id); 3913 E := Base_Type (Entity (Id)); 3914 3915 -- There are many cases where a use_type_clause may be reanalyzed due to 3916 -- manipulation of the scope stack so we much guard against those cases 3917 -- here, otherwise, we must add the new use_type_clause to the previous 3918 -- use_type_clause chain in order to mark redundant use_type_clauses as 3919 -- used. 3920 3921 if Present (Current_Use_Clause (E)) 3922 and then Current_Use_Clause (E) /= N 3923 and then No (Prev_Use_Clause (N)) 3924 then 3925 Set_Prev_Use_Clause (N, Current_Use_Clause (E)); 3926 end if; 3927 3928 -- If the Used_Operations list is already initialized, the clause has 3929 -- been analyzed previously, and it is being reinstalled, for example 3930 -- when the clause appears in a package spec and we are compiling the 3931 -- corresponding package body. In that case, make the entities on the 3932 -- existing list use_visible, and mark the corresponding types In_Use. 3933 3934 if Present (Used_Operations (N)) then 3935 declare 3936 Elmt : Elmt_Id; 3937 3938 begin 3939 Use_One_Type (Subtype_Mark (N), Installed => True); 3940 3941 Elmt := First_Elmt (Used_Operations (N)); 3942 while Present (Elmt) loop 3943 Set_Is_Potentially_Use_Visible (Node (Elmt)); 3944 Next_Elmt (Elmt); 3945 end loop; 3946 end; 3947 3948 return; 3949 end if; 3950 3951 -- Otherwise, create new list and attach to it the operations that are 3952 -- made use-visible by the clause. 3953 3954 Set_Used_Operations (N, New_Elmt_List); 3955 E := Entity (Id); 3956 3957 if E /= Any_Type then 3958 Use_One_Type (Id); 3959 3960 if Nkind (Parent (N)) = N_Compilation_Unit then 3961 if Nkind (Id) = N_Identifier then 3962 Error_Msg_N ("type is not directly visible", Id); 3963 3964 elsif Is_Child_Unit (Scope (E)) 3965 and then Scope (E) /= System_Aux_Id 3966 then 3967 Check_In_Previous_With_Clause (N, Prefix (Id)); 3968 end if; 3969 end if; 3970 3971 else 3972 -- If the use_type_clause appears in a compilation unit context, 3973 -- check whether it comes from a unit that may appear in a 3974 -- limited_with_clause, for a better error message. 3975 3976 if Nkind (Parent (N)) = N_Compilation_Unit 3977 and then Nkind (Id) /= N_Identifier 3978 then 3979 declare 3980 Item : Node_Id; 3981 Pref : Node_Id; 3982 3983 function Mentioned (Nam : Node_Id) return Boolean; 3984 -- Check whether the prefix of expanded name for the type 3985 -- appears in the prefix of some limited_with_clause. 3986 3987 --------------- 3988 -- Mentioned -- 3989 --------------- 3990 3991 function Mentioned (Nam : Node_Id) return Boolean is 3992 begin 3993 return Nkind (Name (Item)) = N_Selected_Component 3994 and then Chars (Prefix (Name (Item))) = Chars (Nam); 3995 end Mentioned; 3996 3997 begin 3998 Pref := Prefix (Id); 3999 Item := First (Context_Items (Parent (N))); 4000 while Present (Item) and then Item /= N loop 4001 if Nkind (Item) = N_With_Clause 4002 and then Limited_Present (Item) 4003 and then Mentioned (Pref) 4004 then 4005 Change_Error_Text 4006 (Get_Msg_Id, "premature usage of incomplete type"); 4007 end if; 4008 4009 Next (Item); 4010 end loop; 4011 end; 4012 end if; 4013 end if; 4014 4015 Mark_Ghost_Clause (N); 4016 end Analyze_Use_Type; 4017 4018 ------------------------ 4019 -- Attribute_Renaming -- 4020 ------------------------ 4021 4022 procedure Attribute_Renaming (N : Node_Id) is 4023 Loc : constant Source_Ptr := Sloc (N); 4024 Nam : constant Node_Id := Name (N); 4025 Spec : constant Node_Id := Specification (N); 4026 New_S : constant Entity_Id := Defining_Unit_Name (Spec); 4027 Aname : constant Name_Id := Attribute_Name (Nam); 4028 4029 Form_Num : Nat := 0; 4030 Expr_List : List_Id := No_List; 4031 4032 Attr_Node : Node_Id; 4033 Body_Node : Node_Id; 4034 Param_Spec : Node_Id; 4035 4036 begin 4037 Generate_Definition (New_S); 4038 4039 -- This procedure is called in the context of subprogram renaming, and 4040 -- thus the attribute must be one that is a subprogram. All of those 4041 -- have at least one formal parameter, with the exceptions of the GNAT 4042 -- attribute 'Img, which GNAT treats as renameable. 4043 4044 if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then 4045 if Aname /= Name_Img then 4046 Error_Msg_N 4047 ("subprogram renaming an attribute must have formals", N); 4048 return; 4049 end if; 4050 4051 else 4052 Param_Spec := First (Parameter_Specifications (Spec)); 4053 while Present (Param_Spec) loop 4054 Form_Num := Form_Num + 1; 4055 4056 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then 4057 Find_Type (Parameter_Type (Param_Spec)); 4058 4059 -- The profile of the new entity denotes the base type (s) of 4060 -- the types given in the specification. For access parameters 4061 -- there are no subtypes involved. 4062 4063 Rewrite (Parameter_Type (Param_Spec), 4064 New_Occurrence_Of 4065 (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc)); 4066 end if; 4067 4068 if No (Expr_List) then 4069 Expr_List := New_List; 4070 end if; 4071 4072 Append_To (Expr_List, 4073 Make_Identifier (Loc, 4074 Chars => Chars (Defining_Identifier (Param_Spec)))); 4075 4076 -- The expressions in the attribute reference are not freeze 4077 -- points. Neither is the attribute as a whole, see below. 4078 4079 Set_Must_Not_Freeze (Last (Expr_List)); 4080 Next (Param_Spec); 4081 end loop; 4082 end if; 4083 4084 -- Immediate error if too many formals. Other mismatches in number or 4085 -- types of parameters are detected when we analyze the body of the 4086 -- subprogram that we construct. 4087 4088 if Form_Num > 2 then 4089 Error_Msg_N ("too many formals for attribute", N); 4090 4091 -- Error if the attribute reference has expressions that look like 4092 -- formal parameters. 4093 4094 elsif Present (Expressions (Nam)) then 4095 Error_Msg_N ("illegal expressions in attribute reference", Nam); 4096 4097 elsif 4098 Nam_In (Aname, Name_Compose, Name_Exponent, Name_Leading_Part, 4099 Name_Pos, Name_Round, Name_Scaling, 4100 Name_Val) 4101 then 4102 if Nkind (N) = N_Subprogram_Renaming_Declaration 4103 and then Present (Corresponding_Formal_Spec (N)) 4104 then 4105 Error_Msg_N 4106 ("generic actual cannot be attribute involving universal type", 4107 Nam); 4108 else 4109 Error_Msg_N 4110 ("attribute involving a universal type cannot be renamed", 4111 Nam); 4112 end if; 4113 end if; 4114 4115 -- Rewrite attribute node to have a list of expressions corresponding to 4116 -- the subprogram formals. A renaming declaration is not a freeze point, 4117 -- and the analysis of the attribute reference should not freeze the 4118 -- type of the prefix. We use the original node in the renaming so that 4119 -- its source location is preserved, and checks on stream attributes are 4120 -- properly applied. 4121 4122 Attr_Node := Relocate_Node (Nam); 4123 Set_Expressions (Attr_Node, Expr_List); 4124 4125 Set_Must_Not_Freeze (Attr_Node); 4126 Set_Must_Not_Freeze (Prefix (Nam)); 4127 4128 -- Case of renaming a function 4129 4130 if Nkind (Spec) = N_Function_Specification then 4131 if Is_Procedure_Attribute_Name (Aname) then 4132 Error_Msg_N ("attribute can only be renamed as procedure", Nam); 4133 return; 4134 end if; 4135 4136 Find_Type (Result_Definition (Spec)); 4137 Rewrite (Result_Definition (Spec), 4138 New_Occurrence_Of 4139 (Base_Type (Entity (Result_Definition (Spec))), Loc)); 4140 4141 Body_Node := 4142 Make_Subprogram_Body (Loc, 4143 Specification => Spec, 4144 Declarations => New_List, 4145 Handled_Statement_Sequence => 4146 Make_Handled_Sequence_Of_Statements (Loc, 4147 Statements => New_List ( 4148 Make_Simple_Return_Statement (Loc, 4149 Expression => Attr_Node)))); 4150 4151 -- Case of renaming a procedure 4152 4153 else 4154 if not Is_Procedure_Attribute_Name (Aname) then 4155 Error_Msg_N ("attribute can only be renamed as function", Nam); 4156 return; 4157 end if; 4158 4159 Body_Node := 4160 Make_Subprogram_Body (Loc, 4161 Specification => Spec, 4162 Declarations => New_List, 4163 Handled_Statement_Sequence => 4164 Make_Handled_Sequence_Of_Statements (Loc, 4165 Statements => New_List (Attr_Node))); 4166 end if; 4167 4168 -- Signal the ABE mechanism that the generated subprogram body has not 4169 -- ABE ramifications. 4170 4171 Set_Was_Attribute_Reference (Body_Node); 4172 4173 -- In case of tagged types we add the body of the generated function to 4174 -- the freezing actions of the type (because in the general case such 4175 -- type is still not frozen). We exclude from this processing generic 4176 -- formal subprograms found in instantiations. 4177 4178 -- We must exclude restricted run-time libraries because 4179 -- entity AST_Handler is defined in package System.Aux_Dec which is not 4180 -- available in those platforms. Note that we cannot use the function 4181 -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because 4182 -- the ZFP run-time library is not defined as a profile, and we do not 4183 -- want to deal with AST_Handler in ZFP mode. 4184 4185 if not Configurable_Run_Time_Mode 4186 and then not Present (Corresponding_Formal_Spec (N)) 4187 and then Etype (Nam) /= RTE (RE_AST_Handler) 4188 then 4189 declare 4190 P : constant Node_Id := Prefix (Nam); 4191 4192 begin 4193 -- The prefix of 'Img is an object that is evaluated for each call 4194 -- of the function that renames it. 4195 4196 if Aname = Name_Img then 4197 Preanalyze_And_Resolve (P); 4198 4199 -- For all other attribute renamings, the prefix is a subtype 4200 4201 else 4202 Find_Type (P); 4203 end if; 4204 4205 -- If the target type is not yet frozen, add the body to the 4206 -- actions to be elaborated at freeze time. 4207 4208 if Is_Tagged_Type (Etype (P)) 4209 and then In_Open_Scopes (Scope (Etype (P))) 4210 then 4211 Ensure_Freeze_Node (Etype (P)); 4212 Append_Freeze_Action (Etype (P), Body_Node); 4213 else 4214 Rewrite (N, Body_Node); 4215 Analyze (N); 4216 Set_Etype (New_S, Base_Type (Etype (New_S))); 4217 end if; 4218 end; 4219 4220 -- Generic formal subprograms or AST_Handler renaming 4221 4222 else 4223 Rewrite (N, Body_Node); 4224 Analyze (N); 4225 Set_Etype (New_S, Base_Type (Etype (New_S))); 4226 end if; 4227 4228 if Is_Compilation_Unit (New_S) then 4229 Error_Msg_N 4230 ("a library unit can only rename another library unit", N); 4231 end if; 4232 4233 -- We suppress elaboration warnings for the resulting entity, since 4234 -- clearly they are not needed, and more particularly, in the case 4235 -- of a generic formal subprogram, the resulting entity can appear 4236 -- after the instantiation itself, and thus look like a bogus case 4237 -- of access before elaboration. 4238 4239 if Legacy_Elaboration_Checks then 4240 Set_Suppress_Elaboration_Warnings (New_S); 4241 end if; 4242 end Attribute_Renaming; 4243 4244 ---------------------- 4245 -- Chain_Use_Clause -- 4246 ---------------------- 4247 4248 procedure Chain_Use_Clause (N : Node_Id) is 4249 Level : Int := Scope_Stack.Last; 4250 Pack : Entity_Id; 4251 4252 begin 4253 -- Common case 4254 4255 if not Is_Compilation_Unit (Current_Scope) 4256 or else not Is_Child_Unit (Current_Scope) 4257 then 4258 null; 4259 4260 -- Common case for compilation unit 4261 4262 elsif Defining_Entity (N => Parent (N), 4263 Empty_On_Errors => True) = Current_Scope 4264 then 4265 null; 4266 4267 else 4268 -- If declaration appears in some other scope, it must be in some 4269 -- parent unit when compiling a child. 4270 4271 Pack := Defining_Entity (Parent (N), Empty_On_Errors => True); 4272 4273 if not In_Open_Scopes (Pack) then 4274 null; 4275 4276 -- If the use clause appears in an ancestor and we are in the 4277 -- private part of the immediate parent, the use clauses are 4278 -- already installed. 4279 4280 elsif Pack /= Scope (Current_Scope) 4281 and then In_Private_Part (Scope (Current_Scope)) 4282 then 4283 null; 4284 4285 else 4286 -- Find entry for parent unit in scope stack 4287 4288 while Scope_Stack.Table (Level).Entity /= Pack loop 4289 Level := Level - 1; 4290 end loop; 4291 end if; 4292 end if; 4293 4294 Set_Next_Use_Clause (N, 4295 Scope_Stack.Table (Level).First_Use_Clause); 4296 Scope_Stack.Table (Level).First_Use_Clause := N; 4297 end Chain_Use_Clause; 4298 4299 --------------------------- 4300 -- Check_Frozen_Renaming -- 4301 --------------------------- 4302 4303 procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is 4304 B_Node : Node_Id; 4305 Old_S : Entity_Id; 4306 4307 begin 4308 if Is_Frozen (Subp) and then not Has_Completion (Subp) then 4309 B_Node := 4310 Build_Renamed_Body 4311 (Parent (Declaration_Node (Subp)), Defining_Entity (N)); 4312 4313 if Is_Entity_Name (Name (N)) then 4314 Old_S := Entity (Name (N)); 4315 4316 if not Is_Frozen (Old_S) 4317 and then Operating_Mode /= Check_Semantics 4318 then 4319 Append_Freeze_Action (Old_S, B_Node); 4320 else 4321 Insert_After (N, B_Node); 4322 Analyze (B_Node); 4323 end if; 4324 4325 if Is_Intrinsic_Subprogram (Old_S) and then not In_Instance then 4326 Error_Msg_N 4327 ("subprogram used in renaming_as_body cannot be intrinsic", 4328 Name (N)); 4329 end if; 4330 4331 else 4332 Insert_After (N, B_Node); 4333 Analyze (B_Node); 4334 end if; 4335 end if; 4336 end Check_Frozen_Renaming; 4337 4338 ------------------------------- 4339 -- Set_Entity_Or_Discriminal -- 4340 ------------------------------- 4341 4342 procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is 4343 P : Node_Id; 4344 4345 begin 4346 -- If the entity is not a discriminant, or else expansion is disabled, 4347 -- simply set the entity. 4348 4349 if not In_Spec_Expression 4350 or else Ekind (E) /= E_Discriminant 4351 or else Inside_A_Generic 4352 then 4353 Set_Entity_With_Checks (N, E); 4354 4355 -- The replacement of a discriminant by the corresponding discriminal 4356 -- is not done for a task discriminant that appears in a default 4357 -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant 4358 -- for details on their handling. 4359 4360 elsif Is_Concurrent_Type (Scope (E)) then 4361 P := Parent (N); 4362 while Present (P) 4363 and then not Nkind_In (P, N_Parameter_Specification, 4364 N_Component_Declaration) 4365 loop 4366 P := Parent (P); 4367 end loop; 4368 4369 if Present (P) 4370 and then Nkind (P) = N_Parameter_Specification 4371 then 4372 null; 4373 4374 else 4375 Set_Entity (N, Discriminal (E)); 4376 end if; 4377 4378 -- Otherwise, this is a discriminant in a context in which 4379 -- it is a reference to the corresponding parameter of the 4380 -- init proc for the enclosing type. 4381 4382 else 4383 Set_Entity (N, Discriminal (E)); 4384 end if; 4385 end Set_Entity_Or_Discriminal; 4386 4387 ----------------------------------- 4388 -- Check_In_Previous_With_Clause -- 4389 ----------------------------------- 4390 4391 procedure Check_In_Previous_With_Clause 4392 (N : Node_Id; 4393 Nam : Entity_Id) 4394 is 4395 Pack : constant Entity_Id := Entity (Original_Node (Nam)); 4396 Item : Node_Id; 4397 Par : Node_Id; 4398 4399 begin 4400 Item := First (Context_Items (Parent (N))); 4401 while Present (Item) and then Item /= N loop 4402 if Nkind (Item) = N_With_Clause 4403 4404 -- Protect the frontend against previous critical errors 4405 4406 and then Nkind (Name (Item)) /= N_Selected_Component 4407 and then Entity (Name (Item)) = Pack 4408 then 4409 Par := Nam; 4410 4411 -- Find root library unit in with_clause 4412 4413 while Nkind (Par) = N_Expanded_Name loop 4414 Par := Prefix (Par); 4415 end loop; 4416 4417 if Is_Child_Unit (Entity (Original_Node (Par))) then 4418 Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); 4419 else 4420 return; 4421 end if; 4422 end if; 4423 4424 Next (Item); 4425 end loop; 4426 4427 -- On exit, package is not mentioned in a previous with_clause. 4428 -- Check if its prefix is. 4429 4430 if Nkind (Nam) = N_Expanded_Name then 4431 Check_In_Previous_With_Clause (N, Prefix (Nam)); 4432 4433 elsif Pack /= Any_Id then 4434 Error_Msg_NE ("& is not visible", Nam, Pack); 4435 end if; 4436 end Check_In_Previous_With_Clause; 4437 4438 --------------------------------- 4439 -- Check_Library_Unit_Renaming -- 4440 --------------------------------- 4441 4442 procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is 4443 New_E : Entity_Id; 4444 4445 begin 4446 if Nkind (Parent (N)) /= N_Compilation_Unit then 4447 return; 4448 4449 -- Check for library unit. Note that we used to check for the scope 4450 -- being Standard here, but that was wrong for Standard itself. 4451 4452 elsif not Is_Compilation_Unit (Old_E) 4453 and then not Is_Child_Unit (Old_E) 4454 then 4455 Error_Msg_N ("renamed unit must be a library unit", Name (N)); 4456 4457 -- Entities defined in Standard (operators and boolean literals) cannot 4458 -- be renamed as library units. 4459 4460 elsif Scope (Old_E) = Standard_Standard 4461 and then Sloc (Old_E) = Standard_Location 4462 then 4463 Error_Msg_N ("renamed unit must be a library unit", Name (N)); 4464 4465 elsif Present (Parent_Spec (N)) 4466 and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration 4467 and then not Is_Child_Unit (Old_E) 4468 then 4469 Error_Msg_N 4470 ("renamed unit must be a child unit of generic parent", Name (N)); 4471 4472 elsif Nkind (N) in N_Generic_Renaming_Declaration 4473 and then Nkind (Name (N)) = N_Expanded_Name 4474 and then Is_Generic_Instance (Entity (Prefix (Name (N)))) 4475 and then Is_Generic_Unit (Old_E) 4476 then 4477 Error_Msg_N 4478 ("renamed generic unit must be a library unit", Name (N)); 4479 4480 elsif Is_Package_Or_Generic_Package (Old_E) then 4481 4482 -- Inherit categorization flags 4483 4484 New_E := Defining_Entity (N); 4485 Set_Is_Pure (New_E, Is_Pure (Old_E)); 4486 Set_Is_Preelaborated (New_E, Is_Preelaborated (Old_E)); 4487 Set_Is_Remote_Call_Interface (New_E, 4488 Is_Remote_Call_Interface (Old_E)); 4489 Set_Is_Remote_Types (New_E, Is_Remote_Types (Old_E)); 4490 Set_Is_Shared_Passive (New_E, Is_Shared_Passive (Old_E)); 4491 end if; 4492 end Check_Library_Unit_Renaming; 4493 4494 ------------------------ 4495 -- Enclosing_Instance -- 4496 ------------------------ 4497 4498 function Enclosing_Instance return Entity_Id is 4499 S : Entity_Id; 4500 4501 begin 4502 if not Is_Generic_Instance (Current_Scope) then 4503 return Empty; 4504 end if; 4505 4506 S := Scope (Current_Scope); 4507 while S /= Standard_Standard loop 4508 if Is_Generic_Instance (S) then 4509 return S; 4510 end if; 4511 4512 S := Scope (S); 4513 end loop; 4514 4515 return Empty; 4516 end Enclosing_Instance; 4517 4518 --------------- 4519 -- End_Scope -- 4520 --------------- 4521 4522 procedure End_Scope is 4523 Id : Entity_Id; 4524 Prev : Entity_Id; 4525 Outer : Entity_Id; 4526 4527 begin 4528 Id := First_Entity (Current_Scope); 4529 while Present (Id) loop 4530 -- An entity in the current scope is not necessarily the first one 4531 -- on its homonym chain. Find its predecessor if any, 4532 -- If it is an internal entity, it will not be in the visibility 4533 -- chain altogether, and there is nothing to unchain. 4534 4535 if Id /= Current_Entity (Id) then 4536 Prev := Current_Entity (Id); 4537 while Present (Prev) 4538 and then Present (Homonym (Prev)) 4539 and then Homonym (Prev) /= Id 4540 loop 4541 Prev := Homonym (Prev); 4542 end loop; 4543 4544 -- Skip to end of loop if Id is not in the visibility chain 4545 4546 if No (Prev) or else Homonym (Prev) /= Id then 4547 goto Next_Ent; 4548 end if; 4549 4550 else 4551 Prev := Empty; 4552 end if; 4553 4554 Set_Is_Immediately_Visible (Id, False); 4555 4556 Outer := Homonym (Id); 4557 while Present (Outer) and then Scope (Outer) = Current_Scope loop 4558 Outer := Homonym (Outer); 4559 end loop; 4560 4561 -- Reset homonym link of other entities, but do not modify link 4562 -- between entities in current scope, so that the back-end can have 4563 -- a proper count of local overloadings. 4564 4565 if No (Prev) then 4566 Set_Name_Entity_Id (Chars (Id), Outer); 4567 4568 elsif Scope (Prev) /= Scope (Id) then 4569 Set_Homonym (Prev, Outer); 4570 end if; 4571 4572 <<Next_Ent>> 4573 Next_Entity (Id); 4574 end loop; 4575 4576 -- If the scope generated freeze actions, place them before the 4577 -- current declaration and analyze them. Type declarations and 4578 -- the bodies of initialization procedures can generate such nodes. 4579 -- We follow the parent chain until we reach a list node, which is 4580 -- the enclosing list of declarations. If the list appears within 4581 -- a protected definition, move freeze nodes outside the protected 4582 -- type altogether. 4583 4584 if Present 4585 (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions) 4586 then 4587 declare 4588 Decl : Node_Id; 4589 L : constant List_Id := Scope_Stack.Table 4590 (Scope_Stack.Last).Pending_Freeze_Actions; 4591 4592 begin 4593 if Is_Itype (Current_Scope) then 4594 Decl := Associated_Node_For_Itype (Current_Scope); 4595 else 4596 Decl := Parent (Current_Scope); 4597 end if; 4598 4599 Pop_Scope; 4600 4601 while not (Is_List_Member (Decl)) 4602 or else Nkind_In (Parent (Decl), N_Protected_Definition, 4603 N_Task_Definition) 4604 loop 4605 Decl := Parent (Decl); 4606 end loop; 4607 4608 Insert_List_Before_And_Analyze (Decl, L); 4609 end; 4610 4611 else 4612 Pop_Scope; 4613 end if; 4614 end End_Scope; 4615 4616 --------------------- 4617 -- End_Use_Clauses -- 4618 --------------------- 4619 4620 procedure End_Use_Clauses (Clause : Node_Id) is 4621 U : Node_Id; 4622 4623 begin 4624 -- Remove use_type_clauses first, because they affect the visibility of 4625 -- operators in subsequent used packages. 4626 4627 U := Clause; 4628 while Present (U) loop 4629 if Nkind (U) = N_Use_Type_Clause then 4630 End_Use_Type (U); 4631 end if; 4632 4633 Next_Use_Clause (U); 4634 end loop; 4635 4636 U := Clause; 4637 while Present (U) loop 4638 if Nkind (U) = N_Use_Package_Clause then 4639 End_Use_Package (U); 4640 end if; 4641 4642 Next_Use_Clause (U); 4643 end loop; 4644 end End_Use_Clauses; 4645 4646 --------------------- 4647 -- End_Use_Package -- 4648 --------------------- 4649 4650 procedure End_Use_Package (N : Node_Id) is 4651 Pack : Entity_Id; 4652 Pack_Name : Node_Id; 4653 Id : Entity_Id; 4654 Elmt : Elmt_Id; 4655 4656 function Is_Primitive_Operator_In_Use 4657 (Op : Entity_Id; 4658 F : Entity_Id) return Boolean; 4659 -- Check whether Op is a primitive operator of a use-visible type 4660 4661 ---------------------------------- 4662 -- Is_Primitive_Operator_In_Use -- 4663 ---------------------------------- 4664 4665 function Is_Primitive_Operator_In_Use 4666 (Op : Entity_Id; 4667 F : Entity_Id) return Boolean 4668 is 4669 T : constant Entity_Id := Base_Type (Etype (F)); 4670 begin 4671 return In_Use (T) and then Scope (T) = Scope (Op); 4672 end Is_Primitive_Operator_In_Use; 4673 4674 -- Start of processing for End_Use_Package 4675 4676 begin 4677 Pack_Name := Name (N); 4678 4679 -- Test that Pack_Name actually denotes a package before processing 4680 4681 if Is_Entity_Name (Pack_Name) 4682 and then Ekind (Entity (Pack_Name)) = E_Package 4683 then 4684 Pack := Entity (Pack_Name); 4685 4686 if In_Open_Scopes (Pack) then 4687 null; 4688 4689 elsif not Redundant_Use (Pack_Name) then 4690 Set_In_Use (Pack, False); 4691 Set_Current_Use_Clause (Pack, Empty); 4692 4693 Id := First_Entity (Pack); 4694 while Present (Id) loop 4695 4696 -- Preserve use-visibility of operators that are primitive 4697 -- operators of a type that is use-visible through an active 4698 -- use_type_clause. 4699 4700 if Nkind (Id) = N_Defining_Operator_Symbol 4701 and then 4702 (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) 4703 or else 4704 (Present (Next_Formal (First_Formal (Id))) 4705 and then 4706 Is_Primitive_Operator_In_Use 4707 (Id, Next_Formal (First_Formal (Id))))) 4708 then 4709 null; 4710 else 4711 Set_Is_Potentially_Use_Visible (Id, False); 4712 end if; 4713 4714 if Is_Private_Type (Id) 4715 and then Present (Full_View (Id)) 4716 then 4717 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 4718 end if; 4719 4720 Next_Entity (Id); 4721 end loop; 4722 4723 if Present (Renamed_Object (Pack)) then 4724 Set_In_Use (Renamed_Object (Pack), False); 4725 Set_Current_Use_Clause (Renamed_Object (Pack), Empty); 4726 end if; 4727 4728 if Chars (Pack) = Name_System 4729 and then Scope (Pack) = Standard_Standard 4730 and then Present_System_Aux 4731 then 4732 Id := First_Entity (System_Aux_Id); 4733 while Present (Id) loop 4734 Set_Is_Potentially_Use_Visible (Id, False); 4735 4736 if Is_Private_Type (Id) 4737 and then Present (Full_View (Id)) 4738 then 4739 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 4740 end if; 4741 4742 Next_Entity (Id); 4743 end loop; 4744 4745 Set_In_Use (System_Aux_Id, False); 4746 end if; 4747 else 4748 Set_Redundant_Use (Pack_Name, False); 4749 end if; 4750 end if; 4751 4752 if Present (Hidden_By_Use_Clause (N)) then 4753 Elmt := First_Elmt (Hidden_By_Use_Clause (N)); 4754 while Present (Elmt) loop 4755 declare 4756 E : constant Entity_Id := Node (Elmt); 4757 4758 begin 4759 -- Reset either Use_Visibility or Direct_Visibility, depending 4760 -- on how the entity was hidden by the use clause. 4761 4762 if In_Use (Scope (E)) 4763 and then Used_As_Generic_Actual (Scope (E)) 4764 then 4765 Set_Is_Potentially_Use_Visible (Node (Elmt)); 4766 else 4767 Set_Is_Immediately_Visible (Node (Elmt)); 4768 end if; 4769 4770 Next_Elmt (Elmt); 4771 end; 4772 end loop; 4773 4774 Set_Hidden_By_Use_Clause (N, No_Elist); 4775 end if; 4776 end End_Use_Package; 4777 4778 ------------------ 4779 -- End_Use_Type -- 4780 ------------------ 4781 4782 procedure End_Use_Type (N : Node_Id) is 4783 Elmt : Elmt_Id; 4784 Id : Entity_Id; 4785 T : Entity_Id; 4786 4787 -- Start of processing for End_Use_Type 4788 4789 begin 4790 Id := Subtype_Mark (N); 4791 4792 -- A call to Rtsfind may occur while analyzing a use_type_clause, in 4793 -- which case the type marks are not resolved yet, so guard against that 4794 -- here. 4795 4796 if Is_Entity_Name (Id) and then Present (Entity (Id)) then 4797 T := Entity (Id); 4798 4799 if T = Any_Type or else From_Limited_With (T) then 4800 null; 4801 4802 -- Note that the use_type_clause may mention a subtype of the type 4803 -- whose primitive operations have been made visible. Here as 4804 -- elsewhere, it is the base type that matters for visibility. 4805 4806 elsif In_Open_Scopes (Scope (Base_Type (T))) then 4807 null; 4808 4809 elsif not Redundant_Use (Id) then 4810 Set_In_Use (T, False); 4811 Set_In_Use (Base_Type (T), False); 4812 Set_Current_Use_Clause (T, Empty); 4813 Set_Current_Use_Clause (Base_Type (T), Empty); 4814 end if; 4815 end if; 4816 4817 if Is_Empty_Elmt_List (Used_Operations (N)) then 4818 return; 4819 4820 else 4821 Elmt := First_Elmt (Used_Operations (N)); 4822 while Present (Elmt) loop 4823 Set_Is_Potentially_Use_Visible (Node (Elmt), False); 4824 Next_Elmt (Elmt); 4825 end loop; 4826 end if; 4827 end End_Use_Type; 4828 4829 -------------------- 4830 -- Entity_Of_Unit -- 4831 -------------------- 4832 4833 function Entity_Of_Unit (U : Node_Id) return Entity_Id is 4834 begin 4835 if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then 4836 return Defining_Entity (Instance_Spec (U)); 4837 else 4838 return Defining_Entity (U); 4839 end if; 4840 end Entity_Of_Unit; 4841 4842 ---------------------- 4843 -- Find_Direct_Name -- 4844 ---------------------- 4845 4846 procedure Find_Direct_Name (N : Node_Id) is 4847 E : Entity_Id; 4848 E2 : Entity_Id; 4849 Msg : Boolean; 4850 4851 Homonyms : Entity_Id; 4852 -- Saves start of homonym chain 4853 4854 Inst : Entity_Id := Empty; 4855 -- Enclosing instance, if any 4856 4857 Nvis_Entity : Boolean; 4858 -- Set True to indicate that there is at least one entity on the homonym 4859 -- chain which, while not visible, is visible enough from the user point 4860 -- of view to warrant an error message of "not visible" rather than 4861 -- undefined. 4862 4863 Nvis_Is_Private_Subprg : Boolean := False; 4864 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais 4865 -- effect concerning library subprograms has been detected. Used to 4866 -- generate the precise error message. 4867 4868 function From_Actual_Package (E : Entity_Id) return Boolean; 4869 -- Returns true if the entity is an actual for a package that is itself 4870 -- an actual for a formal package of the current instance. Such an 4871 -- entity requires special handling because it may be use-visible but 4872 -- hides directly visible entities defined outside the instance, because 4873 -- the corresponding formal did so in the generic. 4874 4875 function Is_Actual_Parameter return Boolean; 4876 -- This function checks if the node N is an identifier that is an actual 4877 -- parameter of a procedure call. If so it returns True, otherwise it 4878 -- return False. The reason for this check is that at this stage we do 4879 -- not know what procedure is being called if the procedure might be 4880 -- overloaded, so it is premature to go setting referenced flags or 4881 -- making calls to Generate_Reference. We will wait till Resolve_Actuals 4882 -- for that processing 4883 4884 function Known_But_Invisible (E : Entity_Id) return Boolean; 4885 -- This function determines whether a reference to the entity E, which 4886 -- is not visible, can reasonably be considered to be known to the 4887 -- writer of the reference. This is a heuristic test, used only for 4888 -- the purposes of figuring out whether we prefer to complain that an 4889 -- entity is undefined or invisible (and identify the declaration of 4890 -- the invisible entity in the latter case). The point here is that we 4891 -- don't want to complain that something is invisible and then point to 4892 -- something entirely mysterious to the writer. 4893 4894 procedure Nvis_Messages; 4895 -- Called if there are no visible entries for N, but there is at least 4896 -- one non-directly visible, or hidden declaration. This procedure 4897 -- outputs an appropriate set of error messages. 4898 4899 procedure Undefined (Nvis : Boolean); 4900 -- This function is called if the current node has no corresponding 4901 -- visible entity or entities. The value set in Msg indicates whether 4902 -- an error message was generated (multiple error messages for the 4903 -- same variable are generally suppressed, see body for details). 4904 -- Msg is True if an error message was generated, False if not. This 4905 -- value is used by the caller to determine whether or not to output 4906 -- additional messages where appropriate. The parameter is set False 4907 -- to get the message "X is undefined", and True to get the message 4908 -- "X is not visible". 4909 4910 ------------------------- 4911 -- From_Actual_Package -- 4912 ------------------------- 4913 4914 function From_Actual_Package (E : Entity_Id) return Boolean is 4915 Scop : constant Entity_Id := Scope (E); 4916 -- Declared scope of candidate entity 4917 4918 function Declared_In_Actual (Pack : Entity_Id) return Boolean; 4919 -- Recursive function that does the work and examines actuals of 4920 -- actual packages of current instance. 4921 4922 ------------------------ 4923 -- Declared_In_Actual -- 4924 ------------------------ 4925 4926 function Declared_In_Actual (Pack : Entity_Id) return Boolean is 4927 Act : Entity_Id; 4928 4929 begin 4930 if No (Associated_Formal_Package (Pack)) then 4931 return False; 4932 4933 else 4934 Act := First_Entity (Pack); 4935 while Present (Act) loop 4936 if Renamed_Object (Pack) = Scop then 4937 return True; 4938 4939 -- Check for end of list of actuals 4940 4941 elsif Ekind (Act) = E_Package 4942 and then Renamed_Object (Act) = Pack 4943 then 4944 return False; 4945 4946 elsif Ekind (Act) = E_Package 4947 and then Declared_In_Actual (Act) 4948 then 4949 return True; 4950 end if; 4951 4952 Next_Entity (Act); 4953 end loop; 4954 4955 return False; 4956 end if; 4957 end Declared_In_Actual; 4958 4959 -- Local variables 4960 4961 Act : Entity_Id; 4962 4963 -- Start of processing for From_Actual_Package 4964 4965 begin 4966 if not In_Instance then 4967 return False; 4968 4969 else 4970 Inst := Current_Scope; 4971 while Present (Inst) 4972 and then Ekind (Inst) /= E_Package 4973 and then not Is_Generic_Instance (Inst) 4974 loop 4975 Inst := Scope (Inst); 4976 end loop; 4977 4978 if No (Inst) then 4979 return False; 4980 end if; 4981 4982 Act := First_Entity (Inst); 4983 while Present (Act) loop 4984 if Ekind (Act) = E_Package 4985 and then Declared_In_Actual (Act) 4986 then 4987 return True; 4988 end if; 4989 4990 Next_Entity (Act); 4991 end loop; 4992 4993 return False; 4994 end if; 4995 end From_Actual_Package; 4996 4997 ------------------------- 4998 -- Is_Actual_Parameter -- 4999 ------------------------- 5000 5001 function Is_Actual_Parameter return Boolean is 5002 begin 5003 return 5004 Nkind (N) = N_Identifier 5005 and then 5006 (Nkind (Parent (N)) = N_Procedure_Call_Statement 5007 or else 5008 (Nkind (Parent (N)) = N_Parameter_Association 5009 and then N = Explicit_Actual_Parameter (Parent (N)) 5010 and then Nkind (Parent (Parent (N))) = 5011 N_Procedure_Call_Statement)); 5012 end Is_Actual_Parameter; 5013 5014 ------------------------- 5015 -- Known_But_Invisible -- 5016 ------------------------- 5017 5018 function Known_But_Invisible (E : Entity_Id) return Boolean is 5019 Fname : File_Name_Type; 5020 5021 begin 5022 -- Entities in Standard are always considered to be known 5023 5024 if Sloc (E) <= Standard_Location then 5025 return True; 5026 5027 -- An entity that does not come from source is always considered 5028 -- to be unknown, since it is an artifact of code expansion. 5029 5030 elsif not Comes_From_Source (E) then 5031 return False; 5032 5033 -- In gnat internal mode, we consider all entities known. The 5034 -- historical reason behind this discrepancy is not known??? But the 5035 -- only effect is to modify the error message given, so it is not 5036 -- critical. Since it only affects the exact wording of error 5037 -- messages in illegal programs, we do not mention this as an 5038 -- effect of -gnatg, since it is not a language modification. 5039 5040 elsif GNAT_Mode then 5041 return True; 5042 end if; 5043 5044 -- Here we have an entity that is not from package Standard, and 5045 -- which comes from Source. See if it comes from an internal file. 5046 5047 Fname := Unit_File_Name (Get_Source_Unit (E)); 5048 5049 -- Case of from internal file 5050 5051 if In_Internal_Unit (E) then 5052 5053 -- Private part entities in internal files are never considered 5054 -- to be known to the writer of normal application code. 5055 5056 if Is_Hidden (E) then 5057 return False; 5058 end if; 5059 5060 -- Entities from System packages other than System and 5061 -- System.Storage_Elements are not considered to be known. 5062 -- System.Auxxxx files are also considered known to the user. 5063 5064 -- Should refine this at some point to generally distinguish 5065 -- between known and unknown internal files ??? 5066 5067 Get_Name_String (Fname); 5068 5069 return 5070 Name_Len < 2 5071 or else 5072 Name_Buffer (1 .. 2) /= "s-" 5073 or else 5074 Name_Buffer (3 .. 8) = "stoele" 5075 or else 5076 Name_Buffer (3 .. 5) = "aux"; 5077 5078 -- If not an internal file, then entity is definitely known, even if 5079 -- it is in a private part (the message generated will note that it 5080 -- is in a private part). 5081 5082 else 5083 return True; 5084 end if; 5085 end Known_But_Invisible; 5086 5087 ------------------- 5088 -- Nvis_Messages -- 5089 ------------------- 5090 5091 procedure Nvis_Messages is 5092 Comp_Unit : Node_Id; 5093 Ent : Entity_Id; 5094 Found : Boolean := False; 5095 Hidden : Boolean := False; 5096 Item : Node_Id; 5097 5098 begin 5099 -- Ada 2005 (AI-262): Generate a precise error concerning the 5100 -- Beaujolais effect that was previously detected 5101 5102 if Nvis_Is_Private_Subprg then 5103 5104 pragma Assert (Nkind (E2) = N_Defining_Identifier 5105 and then Ekind (E2) = E_Function 5106 and then Scope (E2) = Standard_Standard 5107 and then Has_Private_With (E2)); 5108 5109 -- Find the sloc corresponding to the private with'ed unit 5110 5111 Comp_Unit := Cunit (Current_Sem_Unit); 5112 Error_Msg_Sloc := No_Location; 5113 5114 Item := First (Context_Items (Comp_Unit)); 5115 while Present (Item) loop 5116 if Nkind (Item) = N_With_Clause 5117 and then Private_Present (Item) 5118 and then Entity (Name (Item)) = E2 5119 then 5120 Error_Msg_Sloc := Sloc (Item); 5121 exit; 5122 end if; 5123 5124 Next (Item); 5125 end loop; 5126 5127 pragma Assert (Error_Msg_Sloc /= No_Location); 5128 5129 Error_Msg_N ("(Ada 2005): hidden by private with clause #", N); 5130 return; 5131 end if; 5132 5133 Undefined (Nvis => True); 5134 5135 if Msg then 5136 5137 -- First loop does hidden declarations 5138 5139 Ent := Homonyms; 5140 while Present (Ent) loop 5141 if Is_Potentially_Use_Visible (Ent) then 5142 if not Hidden then 5143 Error_Msg_N -- CODEFIX 5144 ("multiple use clauses cause hiding!", N); 5145 Hidden := True; 5146 end if; 5147 5148 Error_Msg_Sloc := Sloc (Ent); 5149 Error_Msg_N -- CODEFIX 5150 ("hidden declaration#!", N); 5151 end if; 5152 5153 Ent := Homonym (Ent); 5154 end loop; 5155 5156 -- If we found hidden declarations, then that's enough, don't 5157 -- bother looking for non-visible declarations as well. 5158 5159 if Hidden then 5160 return; 5161 end if; 5162 5163 -- Second loop does non-directly visible declarations 5164 5165 Ent := Homonyms; 5166 while Present (Ent) loop 5167 if not Is_Potentially_Use_Visible (Ent) then 5168 5169 -- Do not bother the user with unknown entities 5170 5171 if not Known_But_Invisible (Ent) then 5172 goto Continue; 5173 end if; 5174 5175 Error_Msg_Sloc := Sloc (Ent); 5176 5177 -- Output message noting that there is a non-visible 5178 -- declaration, distinguishing the private part case. 5179 5180 if Is_Hidden (Ent) then 5181 Error_Msg_N ("non-visible (private) declaration#!", N); 5182 5183 -- If the entity is declared in a generic package, it 5184 -- cannot be visible, so there is no point in adding it 5185 -- to the list of candidates if another homograph from a 5186 -- non-generic package has been seen. 5187 5188 elsif Ekind (Scope (Ent)) = E_Generic_Package 5189 and then Found 5190 then 5191 null; 5192 5193 else 5194 Error_Msg_N -- CODEFIX 5195 ("non-visible declaration#!", N); 5196 5197 if Ekind (Scope (Ent)) /= E_Generic_Package then 5198 Found := True; 5199 end if; 5200 5201 if Is_Compilation_Unit (Ent) 5202 and then 5203 Nkind (Parent (Parent (N))) = N_Use_Package_Clause 5204 then 5205 Error_Msg_Qual_Level := 99; 5206 Error_Msg_NE -- CODEFIX 5207 ("\\missing `WITH &;`", N, Ent); 5208 Error_Msg_Qual_Level := 0; 5209 end if; 5210 5211 if Ekind (Ent) = E_Discriminant 5212 and then Present (Corresponding_Discriminant (Ent)) 5213 and then Scope (Corresponding_Discriminant (Ent)) = 5214 Etype (Scope (Ent)) 5215 then 5216 Error_Msg_N 5217 ("inherited discriminant not allowed here" & 5218 " (RM 3.8 (12), 3.8.1 (6))!", N); 5219 end if; 5220 end if; 5221 5222 -- Set entity and its containing package as referenced. We 5223 -- can't be sure of this, but this seems a better choice 5224 -- to avoid unused entity messages. 5225 5226 if Comes_From_Source (Ent) then 5227 Set_Referenced (Ent); 5228 Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent))); 5229 end if; 5230 end if; 5231 5232 <<Continue>> 5233 Ent := Homonym (Ent); 5234 end loop; 5235 end if; 5236 end Nvis_Messages; 5237 5238 --------------- 5239 -- Undefined -- 5240 --------------- 5241 5242 procedure Undefined (Nvis : Boolean) is 5243 Emsg : Error_Msg_Id; 5244 5245 begin 5246 -- We should never find an undefined internal name. If we do, then 5247 -- see if we have previous errors. If so, ignore on the grounds that 5248 -- it is probably a cascaded message (e.g. a block label from a badly 5249 -- formed block). If no previous errors, then we have a real internal 5250 -- error of some kind so raise an exception. 5251 5252 if Is_Internal_Name (Chars (N)) then 5253 if Total_Errors_Detected /= 0 then 5254 return; 5255 else 5256 raise Program_Error; 5257 end if; 5258 end if; 5259 5260 -- A very specialized error check, if the undefined variable is 5261 -- a case tag, and the case type is an enumeration type, check 5262 -- for a possible misspelling, and if so, modify the identifier 5263 5264 -- Named aggregate should also be handled similarly ??? 5265 5266 if Nkind (N) = N_Identifier 5267 and then Nkind (Parent (N)) = N_Case_Statement_Alternative 5268 then 5269 declare 5270 Case_Stm : constant Node_Id := Parent (Parent (N)); 5271 Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); 5272 5273 Lit : Node_Id; 5274 5275 begin 5276 if Is_Enumeration_Type (Case_Typ) 5277 and then not Is_Standard_Character_Type (Case_Typ) 5278 then 5279 Lit := First_Literal (Case_Typ); 5280 Get_Name_String (Chars (Lit)); 5281 5282 if Chars (Lit) /= Chars (N) 5283 and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) 5284 then 5285 Error_Msg_Node_2 := Lit; 5286 Error_Msg_N -- CODEFIX 5287 ("& is undefined, assume misspelling of &", N); 5288 Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); 5289 return; 5290 end if; 5291 5292 Lit := Next_Literal (Lit); 5293 end if; 5294 end; 5295 end if; 5296 5297 -- Normal processing 5298 5299 Set_Entity (N, Any_Id); 5300 Set_Etype (N, Any_Type); 5301 5302 -- We use the table Urefs to keep track of entities for which we 5303 -- have issued errors for undefined references. Multiple errors 5304 -- for a single name are normally suppressed, however we modify 5305 -- the error message to alert the programmer to this effect. 5306 5307 for J in Urefs.First .. Urefs.Last loop 5308 if Chars (N) = Chars (Urefs.Table (J).Node) then 5309 if Urefs.Table (J).Err /= No_Error_Msg 5310 and then Sloc (N) /= Urefs.Table (J).Loc 5311 then 5312 Error_Msg_Node_1 := Urefs.Table (J).Node; 5313 5314 if Urefs.Table (J).Nvis then 5315 Change_Error_Text (Urefs.Table (J).Err, 5316 "& is not visible (more references follow)"); 5317 else 5318 Change_Error_Text (Urefs.Table (J).Err, 5319 "& is undefined (more references follow)"); 5320 end if; 5321 5322 Urefs.Table (J).Err := No_Error_Msg; 5323 end if; 5324 5325 -- Although we will set Msg False, and thus suppress the 5326 -- message, we also set Error_Posted True, to avoid any 5327 -- cascaded messages resulting from the undefined reference. 5328 5329 Msg := False; 5330 Set_Error_Posted (N, True); 5331 return; 5332 end if; 5333 end loop; 5334 5335 -- If entry not found, this is first undefined occurrence 5336 5337 if Nvis then 5338 Error_Msg_N ("& is not visible!", N); 5339 Emsg := Get_Msg_Id; 5340 5341 else 5342 Error_Msg_N ("& is undefined!", N); 5343 Emsg := Get_Msg_Id; 5344 5345 -- A very bizarre special check, if the undefined identifier 5346 -- is put or put_line, then add a special error message (since 5347 -- this is a very common error for beginners to make). 5348 5349 if Nam_In (Chars (N), Name_Put, Name_Put_Line) then 5350 Error_Msg_N -- CODEFIX 5351 ("\\possible missing `WITH Ada.Text_'I'O; " & 5352 "USE Ada.Text_'I'O`!", N); 5353 5354 -- Another special check if N is the prefix of a selected 5355 -- component which is a known unit, add message complaining 5356 -- about missing with for this unit. 5357 5358 elsif Nkind (Parent (N)) = N_Selected_Component 5359 and then N = Prefix (Parent (N)) 5360 and then Is_Known_Unit (Parent (N)) 5361 then 5362 Error_Msg_Node_2 := Selector_Name (Parent (N)); 5363 Error_Msg_N -- CODEFIX 5364 ("\\missing `WITH &.&;`", Prefix (Parent (N))); 5365 end if; 5366 5367 -- Now check for possible misspellings 5368 5369 declare 5370 E : Entity_Id; 5371 Ematch : Entity_Id := Empty; 5372 5373 Last_Name_Id : constant Name_Id := 5374 Name_Id (Nat (First_Name_Id) + 5375 Name_Entries_Count - 1); 5376 5377 begin 5378 for Nam in First_Name_Id .. Last_Name_Id loop 5379 E := Get_Name_Entity_Id (Nam); 5380 5381 if Present (E) 5382 and then (Is_Immediately_Visible (E) 5383 or else 5384 Is_Potentially_Use_Visible (E)) 5385 then 5386 if Is_Bad_Spelling_Of (Chars (N), Nam) then 5387 Ematch := E; 5388 exit; 5389 end if; 5390 end if; 5391 end loop; 5392 5393 if Present (Ematch) then 5394 Error_Msg_NE -- CODEFIX 5395 ("\possible misspelling of&", N, Ematch); 5396 end if; 5397 end; 5398 end if; 5399 5400 -- Make entry in undefined references table unless the full errors 5401 -- switch is set, in which case by refraining from generating the 5402 -- table entry, we guarantee that we get an error message for every 5403 -- undefined reference. The entry is not added if we are ignoring 5404 -- errors. 5405 5406 if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then 5407 Urefs.Append ( 5408 (Node => N, 5409 Err => Emsg, 5410 Nvis => Nvis, 5411 Loc => Sloc (N))); 5412 end if; 5413 5414 Msg := True; 5415 end Undefined; 5416 5417 -- Local variables 5418 5419 Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; 5420 5421 Nested_Inst : Entity_Id := Empty; 5422 -- The entity of a nested instance which appears within Inst (if any) 5423 5424 -- Start of processing for Find_Direct_Name 5425 5426 begin 5427 -- If the entity pointer is already set, this is an internal node, or 5428 -- a node that is analyzed more than once, after a tree modification. 5429 -- In such a case there is no resolution to perform, just set the type. 5430 5431 if Present (Entity (N)) then 5432 if Is_Type (Entity (N)) then 5433 Set_Etype (N, Entity (N)); 5434 5435 else 5436 declare 5437 Entyp : constant Entity_Id := Etype (Entity (N)); 5438 5439 begin 5440 -- One special case here. If the Etype field is already set, 5441 -- and references the packed array type corresponding to the 5442 -- etype of the referenced entity, then leave it alone. This 5443 -- happens for trees generated from Exp_Pakd, where expressions 5444 -- can be deliberately "mis-typed" to the packed array type. 5445 5446 if Is_Array_Type (Entyp) 5447 and then Is_Packed (Entyp) 5448 and then Present (Etype (N)) 5449 and then Etype (N) = Packed_Array_Impl_Type (Entyp) 5450 then 5451 null; 5452 5453 -- If not that special case, then just reset the Etype 5454 5455 else 5456 Set_Etype (N, Etype (Entity (N))); 5457 end if; 5458 end; 5459 end if; 5460 5461 -- Although the marking of use clauses happens at the end of 5462 -- Find_Direct_Name, a certain case where a generic actual satisfies 5463 -- a use clause must be checked here due to how the generic machinery 5464 -- handles the analysis of said actuals. 5465 5466 if In_Instance 5467 and then Nkind (Parent (N)) = N_Generic_Association 5468 then 5469 Mark_Use_Clauses (Entity (N)); 5470 end if; 5471 5472 return; 5473 end if; 5474 5475 -- Preserve relevant elaboration-related attributes of the context which 5476 -- are no longer available or very expensive to recompute once analysis, 5477 -- resolution, and expansion are over. 5478 5479 if Nkind (N) = N_Identifier then 5480 Mark_Elaboration_Attributes 5481 (N_Id => N, 5482 Modes => True); 5483 end if; 5484 5485 -- Here if Entity pointer was not set, we need full visibility analysis 5486 -- First we generate debugging output if the debug E flag is set. 5487 5488 if Debug_Flag_E then 5489 Write_Str ("Looking for "); 5490 Write_Name (Chars (N)); 5491 Write_Eol; 5492 end if; 5493 5494 Homonyms := Current_Entity (N); 5495 Nvis_Entity := False; 5496 5497 E := Homonyms; 5498 while Present (E) loop 5499 5500 -- If entity is immediately visible or potentially use visible, then 5501 -- process the entity and we are done. 5502 5503 if Is_Immediately_Visible (E) then 5504 goto Immediately_Visible_Entity; 5505 5506 elsif Is_Potentially_Use_Visible (E) then 5507 goto Potentially_Use_Visible_Entity; 5508 5509 -- Note if a known but invisible entity encountered 5510 5511 elsif Known_But_Invisible (E) then 5512 Nvis_Entity := True; 5513 end if; 5514 5515 -- Move to next entity in chain and continue search 5516 5517 E := Homonym (E); 5518 end loop; 5519 5520 -- If no entries on homonym chain that were potentially visible, 5521 -- and no entities reasonably considered as non-visible, then 5522 -- we have a plain undefined reference, with no additional 5523 -- explanation required. 5524 5525 if not Nvis_Entity then 5526 Undefined (Nvis => False); 5527 5528 -- Otherwise there is at least one entry on the homonym chain that 5529 -- is reasonably considered as being known and non-visible. 5530 5531 else 5532 Nvis_Messages; 5533 end if; 5534 5535 goto Done; 5536 5537 -- Processing for a potentially use visible entry found. We must search 5538 -- the rest of the homonym chain for two reasons. First, if there is a 5539 -- directly visible entry, then none of the potentially use-visible 5540 -- entities are directly visible (RM 8.4(10)). Second, we need to check 5541 -- for the case of multiple potentially use-visible entries hiding one 5542 -- another and as a result being non-directly visible (RM 8.4(11)). 5543 5544 <<Potentially_Use_Visible_Entity>> declare 5545 Only_One_Visible : Boolean := True; 5546 All_Overloadable : Boolean := Is_Overloadable (E); 5547 5548 begin 5549 E2 := Homonym (E); 5550 while Present (E2) loop 5551 if Is_Immediately_Visible (E2) then 5552 5553 -- If the use-visible entity comes from the actual for a 5554 -- formal package, it hides a directly visible entity from 5555 -- outside the instance. 5556 5557 if From_Actual_Package (E) 5558 and then Scope_Depth (E2) < Scope_Depth (Inst) 5559 then 5560 goto Found; 5561 else 5562 E := E2; 5563 goto Immediately_Visible_Entity; 5564 end if; 5565 5566 elsif Is_Potentially_Use_Visible (E2) then 5567 Only_One_Visible := False; 5568 All_Overloadable := All_Overloadable and Is_Overloadable (E2); 5569 5570 -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect 5571 -- that can occur in private_with clauses. Example: 5572 5573 -- with A; 5574 -- private with B; package A is 5575 -- package C is function B return Integer; 5576 -- use A; end A; 5577 -- V1 : Integer := B; 5578 -- private function B return Integer; 5579 -- V2 : Integer := B; 5580 -- end C; 5581 5582 -- V1 resolves to A.B, but V2 resolves to library unit B 5583 5584 elsif Ekind (E2) = E_Function 5585 and then Scope (E2) = Standard_Standard 5586 and then Has_Private_With (E2) 5587 then 5588 Only_One_Visible := False; 5589 All_Overloadable := False; 5590 Nvis_Is_Private_Subprg := True; 5591 exit; 5592 end if; 5593 5594 E2 := Homonym (E2); 5595 end loop; 5596 5597 -- On falling through this loop, we have checked that there are no 5598 -- immediately visible entities. Only_One_Visible is set if exactly 5599 -- one potentially use visible entity exists. All_Overloadable is 5600 -- set if all the potentially use visible entities are overloadable. 5601 -- The condition for legality is that either there is one potentially 5602 -- use visible entity, or if there is more than one, then all of them 5603 -- are overloadable. 5604 5605 if Only_One_Visible or All_Overloadable then 5606 goto Found; 5607 5608 -- If there is more than one potentially use-visible entity and at 5609 -- least one of them non-overloadable, we have an error (RM 8.4(11)). 5610 -- Note that E points to the first such entity on the homonym list. 5611 5612 else 5613 -- If one of the entities is declared in an actual package, it 5614 -- was visible in the generic, and takes precedence over other 5615 -- entities that are potentially use-visible. The same applies 5616 -- if the entity is declared in a local instantiation of the 5617 -- current instance. 5618 5619 if In_Instance then 5620 5621 -- Find the current instance 5622 5623 Inst := Current_Scope; 5624 while Present (Inst) and then Inst /= Standard_Standard loop 5625 if Is_Generic_Instance (Inst) then 5626 exit; 5627 end if; 5628 5629 Inst := Scope (Inst); 5630 end loop; 5631 5632 -- Reexamine the candidate entities, giving priority to those 5633 -- that were visible within the generic. 5634 5635 E2 := E; 5636 while Present (E2) loop 5637 Nested_Inst := Nearest_Enclosing_Instance (E2); 5638 5639 -- The entity is declared within an actual package, or in a 5640 -- nested instance. The ">=" accounts for the case where the 5641 -- current instance and the nested instance are the same. 5642 5643 if From_Actual_Package (E2) 5644 or else (Present (Nested_Inst) 5645 and then Scope_Depth (Nested_Inst) >= 5646 Scope_Depth (Inst)) 5647 then 5648 E := E2; 5649 goto Found; 5650 end if; 5651 5652 E2 := Homonym (E2); 5653 end loop; 5654 5655 Nvis_Messages; 5656 goto Done; 5657 5658 elsif Is_Predefined_Unit (Current_Sem_Unit) then 5659 -- A use clause in the body of a system file creates conflict 5660 -- with some entity in a user scope, while rtsfind is active. 5661 -- Keep only the entity coming from another predefined unit. 5662 5663 E2 := E; 5664 while Present (E2) loop 5665 if In_Predefined_Unit (E2) then 5666 E := E2; 5667 goto Found; 5668 end if; 5669 5670 E2 := Homonym (E2); 5671 end loop; 5672 5673 -- Entity must exist because predefined unit is correct 5674 5675 raise Program_Error; 5676 5677 else 5678 Nvis_Messages; 5679 goto Done; 5680 end if; 5681 end if; 5682 end; 5683 5684 -- Come here with E set to the first immediately visible entity on 5685 -- the homonym chain. This is the one we want unless there is another 5686 -- immediately visible entity further on in the chain for an inner 5687 -- scope (RM 8.3(8)). 5688 5689 <<Immediately_Visible_Entity>> declare 5690 Level : Int; 5691 Scop : Entity_Id; 5692 5693 begin 5694 -- Find scope level of initial entity. When compiling through 5695 -- Rtsfind, the previous context is not completely invisible, and 5696 -- an outer entity may appear on the chain, whose scope is below 5697 -- the entry for Standard that delimits the current scope stack. 5698 -- Indicate that the level for this spurious entry is outside of 5699 -- the current scope stack. 5700 5701 Level := Scope_Stack.Last; 5702 loop 5703 Scop := Scope_Stack.Table (Level).Entity; 5704 exit when Scop = Scope (E); 5705 Level := Level - 1; 5706 exit when Scop = Standard_Standard; 5707 end loop; 5708 5709 -- Now search remainder of homonym chain for more inner entry 5710 -- If the entity is Standard itself, it has no scope, and we 5711 -- compare it with the stack entry directly. 5712 5713 E2 := Homonym (E); 5714 while Present (E2) loop 5715 if Is_Immediately_Visible (E2) then 5716 5717 -- If a generic package contains a local declaration that 5718 -- has the same name as the generic, there may be a visibility 5719 -- conflict in an instance, where the local declaration must 5720 -- also hide the name of the corresponding package renaming. 5721 -- We check explicitly for a package declared by a renaming, 5722 -- whose renamed entity is an instance that is on the scope 5723 -- stack, and that contains a homonym in the same scope. Once 5724 -- we have found it, we know that the package renaming is not 5725 -- immediately visible, and that the identifier denotes the 5726 -- other entity (and its homonyms if overloaded). 5727 5728 if Scope (E) = Scope (E2) 5729 and then Ekind (E) = E_Package 5730 and then Present (Renamed_Object (E)) 5731 and then Is_Generic_Instance (Renamed_Object (E)) 5732 and then In_Open_Scopes (Renamed_Object (E)) 5733 and then Comes_From_Source (N) 5734 then 5735 Set_Is_Immediately_Visible (E, False); 5736 E := E2; 5737 5738 else 5739 for J in Level + 1 .. Scope_Stack.Last loop 5740 if Scope_Stack.Table (J).Entity = Scope (E2) 5741 or else Scope_Stack.Table (J).Entity = E2 5742 then 5743 Level := J; 5744 E := E2; 5745 exit; 5746 end if; 5747 end loop; 5748 end if; 5749 end if; 5750 5751 E2 := Homonym (E2); 5752 end loop; 5753 5754 -- At the end of that loop, E is the innermost immediately 5755 -- visible entity, so we are all set. 5756 end; 5757 5758 -- Come here with entity found, and stored in E 5759 5760 <<Found>> begin 5761 5762 -- Check violation of No_Wide_Characters restriction 5763 5764 Check_Wide_Character_Restriction (E, N); 5765 5766 -- When distribution features are available (Get_PCS_Name /= 5767 -- Name_No_DSA), a remote access-to-subprogram type is converted 5768 -- into a record type holding whatever information is needed to 5769 -- perform a remote call on an RCI subprogram. In that case we 5770 -- rewrite any occurrence of the RAS type into the equivalent record 5771 -- type here. 'Access attribute references and RAS dereferences are 5772 -- then implemented using specific TSSs. However when distribution is 5773 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the 5774 -- generation of these TSSs, and we must keep the RAS type in its 5775 -- original access-to-subprogram form (since all calls through a 5776 -- value of such type will be local anyway in the absence of a PCS). 5777 5778 if Comes_From_Source (N) 5779 and then Is_Remote_Access_To_Subprogram_Type (E) 5780 and then Ekind (E) = E_Access_Subprogram_Type 5781 and then Expander_Active 5782 and then Get_PCS_Name /= Name_No_DSA 5783 then 5784 Rewrite (N, New_Occurrence_Of (Equivalent_Type (E), Sloc (N))); 5785 goto Done; 5786 end if; 5787 5788 -- Set the entity. Note that the reason we call Set_Entity for the 5789 -- overloadable case, as opposed to Set_Entity_With_Checks is 5790 -- that in the overloaded case, the initial call can set the wrong 5791 -- homonym. The call that sets the right homonym is in Sem_Res and 5792 -- that call does use Set_Entity_With_Checks, so we don't miss 5793 -- a style check. 5794 5795 if Is_Overloadable (E) then 5796 Set_Entity (N, E); 5797 else 5798 Set_Entity_With_Checks (N, E); 5799 end if; 5800 5801 if Is_Type (E) then 5802 Set_Etype (N, E); 5803 else 5804 Set_Etype (N, Get_Full_View (Etype (E))); 5805 end if; 5806 5807 if Debug_Flag_E then 5808 Write_Str (" found "); 5809 Write_Entity_Info (E, " "); 5810 end if; 5811 5812 -- If the Ekind of the entity is Void, it means that all homonyms 5813 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this 5814 -- test is skipped if the current scope is a record and the name is 5815 -- a pragma argument expression (case of Atomic and Volatile pragmas 5816 -- and possibly other similar pragmas added later, which are allowed 5817 -- to reference components in the current record). 5818 5819 if Ekind (E) = E_Void 5820 and then 5821 (not Is_Record_Type (Current_Scope) 5822 or else Nkind (Parent (N)) /= N_Pragma_Argument_Association) 5823 then 5824 Premature_Usage (N); 5825 5826 -- If the entity is overloadable, collect all interpretations of the 5827 -- name for subsequent overload resolution. We optimize a bit here to 5828 -- do this only if we have an overloadable entity that is not on its 5829 -- own on the homonym chain. 5830 5831 elsif Is_Overloadable (E) 5832 and then (Present (Homonym (E)) or else Current_Entity (N) /= E) 5833 then 5834 Collect_Interps (N); 5835 5836 -- If no homonyms were visible, the entity is unambiguous 5837 5838 if not Is_Overloaded (N) then 5839 if not Is_Actual_Parameter then 5840 Generate_Reference (E, N); 5841 end if; 5842 end if; 5843 5844 -- Case of non-overloadable entity, set the entity providing that 5845 -- we do not have the case of a discriminant reference within a 5846 -- default expression. Such references are replaced with the 5847 -- corresponding discriminal, which is the formal corresponding to 5848 -- to the discriminant in the initialization procedure. 5849 5850 else 5851 -- Entity is unambiguous, indicate that it is referenced here 5852 5853 -- For a renaming of an object, always generate simple reference, 5854 -- we don't try to keep track of assignments in this case, except 5855 -- in SPARK mode where renamings are traversed for generating 5856 -- local effects of subprograms. 5857 5858 if Is_Object (E) 5859 and then Present (Renamed_Object (E)) 5860 and then not GNATprove_Mode 5861 then 5862 Generate_Reference (E, N); 5863 5864 -- If the renamed entity is a private protected component, 5865 -- reference the original component as well. This needs to be 5866 -- done because the private renamings are installed before any 5867 -- analysis has occurred. Reference to a private component will 5868 -- resolve to the renaming and the original component will be 5869 -- left unreferenced, hence the following. 5870 5871 if Is_Prival (E) then 5872 Generate_Reference (Prival_Link (E), N); 5873 end if; 5874 5875 -- One odd case is that we do not want to set the Referenced flag 5876 -- if the entity is a label, and the identifier is the label in 5877 -- the source, since this is not a reference from the point of 5878 -- view of the user. 5879 5880 elsif Nkind (Parent (N)) = N_Label then 5881 declare 5882 R : constant Boolean := Referenced (E); 5883 5884 begin 5885 -- Generate reference unless this is an actual parameter 5886 -- (see comment below) 5887 5888 if Is_Actual_Parameter then 5889 Generate_Reference (E, N); 5890 Set_Referenced (E, R); 5891 end if; 5892 end; 5893 5894 -- Normal case, not a label: generate reference 5895 5896 else 5897 if not Is_Actual_Parameter then 5898 5899 -- Package or generic package is always a simple reference 5900 5901 if Ekind_In (E, E_Package, E_Generic_Package) then 5902 Generate_Reference (E, N, 'r'); 5903 5904 -- Else see if we have a left hand side 5905 5906 else 5907 case Is_LHS (N) is 5908 when Yes => 5909 Generate_Reference (E, N, 'm'); 5910 5911 when No => 5912 Generate_Reference (E, N, 'r'); 5913 5914 -- If we don't know now, generate reference later 5915 5916 when Unknown => 5917 Deferred_References.Append ((E, N)); 5918 end case; 5919 end if; 5920 end if; 5921 end if; 5922 5923 Set_Entity_Or_Discriminal (N, E); 5924 5925 -- The name may designate a generalized reference, in which case 5926 -- the dereference interpretation will be included. Context is 5927 -- one in which a name is legal. 5928 5929 if Ada_Version >= Ada_2012 5930 and then 5931 (Nkind (Parent (N)) in N_Subexpr 5932 or else Nkind_In (Parent (N), N_Assignment_Statement, 5933 N_Object_Declaration, 5934 N_Parameter_Association)) 5935 then 5936 Check_Implicit_Dereference (N, Etype (E)); 5937 end if; 5938 end if; 5939 end; 5940 5941 -- Mark relevant use-type and use-package clauses as effective if the 5942 -- node in question is not overloaded and therefore does not require 5943 -- resolution. 5944 -- 5945 -- Note: Generic actual subprograms do not follow the normal resolution 5946 -- path, so ignore the fact that they are overloaded and mark them 5947 -- anyway. 5948 5949 if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then 5950 Mark_Use_Clauses (N); 5951 end if; 5952 5953 -- Come here with entity set 5954 5955 <<Done>> 5956 Check_Restriction_No_Use_Of_Entity (N); 5957 5958 -- Annotate the tree by creating a variable reference marker in case the 5959 -- original variable reference is folded or optimized away. The variable 5960 -- reference marker is automatically saved for later examination by the 5961 -- ABE Processing phase. Variable references which act as actuals in a 5962 -- call require special processing and are left to Resolve_Actuals. The 5963 -- reference is a write when it appears on the left hand side of an 5964 -- assignment. 5965 5966 if not Within_Subprogram_Call (N) then 5967 Build_Variable_Reference_Marker 5968 (N => N, 5969 Read => not Is_Assignment_LHS, 5970 Write => Is_Assignment_LHS); 5971 end if; 5972 end Find_Direct_Name; 5973 5974 ------------------------ 5975 -- Find_Expanded_Name -- 5976 ------------------------ 5977 5978 -- This routine searches the homonym chain of the entity until it finds 5979 -- an entity declared in the scope denoted by the prefix. If the entity 5980 -- is private, it may nevertheless be immediately visible, if we are in 5981 -- the scope of its declaration. 5982 5983 procedure Find_Expanded_Name (N : Node_Id) is 5984 function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean; 5985 -- Determine whether expanded name Nod appears within a pragma which is 5986 -- a suitable context for an abstract view of a state or variable. The 5987 -- following pragmas fall in this category: 5988 -- Depends 5989 -- Global 5990 -- Initializes 5991 -- Refined_Depends 5992 -- Refined_Global 5993 -- 5994 -- In addition, pragma Abstract_State is also considered suitable even 5995 -- though it is an illegal context for an abstract view as this allows 5996 -- for proper resolution of abstract views of variables. This illegal 5997 -- context is later flagged in the analysis of indicator Part_Of. 5998 5999 ----------------------------- 6000 -- In_Abstract_View_Pragma -- 6001 ----------------------------- 6002 6003 function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean is 6004 Par : Node_Id; 6005 6006 begin 6007 -- Climb the parent chain looking for a pragma 6008 6009 Par := Nod; 6010 while Present (Par) loop 6011 if Nkind (Par) = N_Pragma then 6012 if Nam_In (Pragma_Name_Unmapped (Par), 6013 Name_Abstract_State, 6014 Name_Depends, 6015 Name_Global, 6016 Name_Initializes, 6017 Name_Refined_Depends, 6018 Name_Refined_Global) 6019 then 6020 return True; 6021 6022 -- Otherwise the pragma is not a legal context for an abstract 6023 -- view. 6024 6025 else 6026 exit; 6027 end if; 6028 6029 -- Prevent the search from going too far 6030 6031 elsif Is_Body_Or_Package_Declaration (Par) then 6032 exit; 6033 end if; 6034 6035 Par := Parent (Par); 6036 end loop; 6037 6038 return False; 6039 end In_Abstract_View_Pragma; 6040 6041 -- Local variables 6042 6043 Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; 6044 Selector : constant Node_Id := Selector_Name (N); 6045 6046 Candidate : Entity_Id := Empty; 6047 P_Name : Entity_Id; 6048 Id : Entity_Id; 6049 6050 -- Start of processing for Find_Expanded_Name 6051 6052 begin 6053 P_Name := Entity (Prefix (N)); 6054 6055 -- If the prefix is a renamed package, look for the entity in the 6056 -- original package. 6057 6058 if Ekind (P_Name) = E_Package 6059 and then Present (Renamed_Object (P_Name)) 6060 then 6061 P_Name := Renamed_Object (P_Name); 6062 6063 -- Rewrite node with entity field pointing to renamed object 6064 6065 Rewrite (Prefix (N), New_Copy (Prefix (N))); 6066 Set_Entity (Prefix (N), P_Name); 6067 6068 -- If the prefix is an object of a concurrent type, look for 6069 -- the entity in the associated task or protected type. 6070 6071 elsif Is_Concurrent_Type (Etype (P_Name)) then 6072 P_Name := Etype (P_Name); 6073 end if; 6074 6075 Id := Current_Entity (Selector); 6076 6077 declare 6078 Is_New_Candidate : Boolean; 6079 6080 begin 6081 while Present (Id) loop 6082 if Scope (Id) = P_Name then 6083 Candidate := Id; 6084 Is_New_Candidate := True; 6085 6086 -- Handle abstract views of states and variables. These are 6087 -- acceptable candidates only when the reference to the view 6088 -- appears in certain pragmas. 6089 6090 if Ekind (Id) = E_Abstract_State 6091 and then From_Limited_With (Id) 6092 and then Present (Non_Limited_View (Id)) 6093 then 6094 if In_Abstract_View_Pragma (N) then 6095 Candidate := Non_Limited_View (Id); 6096 Is_New_Candidate := True; 6097 6098 -- Hide the candidate because it is not used in a proper 6099 -- context. 6100 6101 else 6102 Candidate := Empty; 6103 Is_New_Candidate := False; 6104 end if; 6105 end if; 6106 6107 -- Ada 2005 (AI-217): Handle shadow entities associated with 6108 -- types declared in limited-withed nested packages. We don't need 6109 -- to handle E_Incomplete_Subtype entities because the entities 6110 -- in the limited view are always E_Incomplete_Type and 6111 -- E_Class_Wide_Type entities (see Build_Limited_Views). 6112 6113 -- Regarding the expression used to evaluate the scope, it 6114 -- is important to note that the limited view also has shadow 6115 -- entities associated nested packages. For this reason the 6116 -- correct scope of the entity is the scope of the real entity. 6117 -- The non-limited view may itself be incomplete, in which case 6118 -- get the full view if available. 6119 6120 elsif Ekind_In (Id, E_Incomplete_Type, E_Class_Wide_Type) 6121 and then From_Limited_With (Id) 6122 and then Present (Non_Limited_View (Id)) 6123 and then Scope (Non_Limited_View (Id)) = P_Name 6124 then 6125 Candidate := Get_Full_View (Non_Limited_View (Id)); 6126 Is_New_Candidate := True; 6127 6128 -- An unusual case arises with a fully qualified name for an 6129 -- entity local to a generic child unit package, within an 6130 -- instantiation of that package. The name of the unit now 6131 -- denotes the renaming created within the instance. This is 6132 -- only relevant in an instance body, see below. 6133 6134 elsif Is_Generic_Instance (Scope (Id)) 6135 and then In_Open_Scopes (Scope (Id)) 6136 and then In_Instance_Body 6137 and then Ekind (Scope (Id)) = E_Package 6138 and then Ekind (Id) = E_Package 6139 and then Renamed_Entity (Id) = Scope (Id) 6140 and then Is_Immediately_Visible (P_Name) 6141 then 6142 Is_New_Candidate := True; 6143 6144 else 6145 Is_New_Candidate := False; 6146 end if; 6147 6148 if Is_New_Candidate then 6149 6150 -- If entity is a child unit, either it is a visible child of 6151 -- the prefix, or we are in the body of a generic prefix, as 6152 -- will happen when a child unit is instantiated in the body 6153 -- of a generic parent. This is because the instance body does 6154 -- not restore the full compilation context, given that all 6155 -- non-local references have been captured. 6156 6157 if Is_Child_Unit (Id) or else P_Name = Standard_Standard then 6158 exit when Is_Visible_Lib_Unit (Id) 6159 or else (Is_Child_Unit (Id) 6160 and then In_Open_Scopes (Scope (Id)) 6161 and then In_Instance_Body); 6162 else 6163 exit when not Is_Hidden (Id); 6164 end if; 6165 6166 exit when Is_Immediately_Visible (Id); 6167 end if; 6168 6169 Id := Homonym (Id); 6170 end loop; 6171 end; 6172 6173 if No (Id) 6174 and then Ekind_In (P_Name, E_Procedure, E_Function) 6175 and then Is_Generic_Instance (P_Name) 6176 then 6177 -- Expanded name denotes entity in (instance of) generic subprogram. 6178 -- The entity may be in the subprogram instance, or may denote one of 6179 -- the formals, which is declared in the enclosing wrapper package. 6180 6181 P_Name := Scope (P_Name); 6182 6183 Id := Current_Entity (Selector); 6184 while Present (Id) loop 6185 exit when Scope (Id) = P_Name; 6186 Id := Homonym (Id); 6187 end loop; 6188 end if; 6189 6190 if No (Id) or else Chars (Id) /= Chars (Selector) then 6191 Set_Etype (N, Any_Type); 6192 6193 -- If we are looking for an entity defined in System, try to find it 6194 -- in the child package that may have been provided as an extension 6195 -- to System. The Extend_System pragma will have supplied the name of 6196 -- the extension, which may have to be loaded. 6197 6198 if Chars (P_Name) = Name_System 6199 and then Scope (P_Name) = Standard_Standard 6200 and then Present (System_Extend_Unit) 6201 and then Present_System_Aux (N) 6202 then 6203 Set_Entity (Prefix (N), System_Aux_Id); 6204 Find_Expanded_Name (N); 6205 return; 6206 6207 -- There is an implicit instance of the predefined operator in 6208 -- the given scope. The operator entity is defined in Standard. 6209 -- Has_Implicit_Operator makes the node into an Expanded_Name. 6210 6211 elsif Nkind (Selector) = N_Operator_Symbol 6212 and then Has_Implicit_Operator (N) 6213 then 6214 return; 6215 6216 -- If there is no literal defined in the scope denoted by the 6217 -- prefix, the literal may belong to (a type derived from) 6218 -- Standard_Character, for which we have no explicit literals. 6219 6220 elsif Nkind (Selector) = N_Character_Literal 6221 and then Has_Implicit_Character_Literal (N) 6222 then 6223 return; 6224 6225 else 6226 -- If the prefix is a single concurrent object, use its name in 6227 -- the error message, rather than that of the anonymous type. 6228 6229 if Is_Concurrent_Type (P_Name) 6230 and then Is_Internal_Name (Chars (P_Name)) 6231 then 6232 Error_Msg_Node_2 := Entity (Prefix (N)); 6233 else 6234 Error_Msg_Node_2 := P_Name; 6235 end if; 6236 6237 if P_Name = System_Aux_Id then 6238 P_Name := Scope (P_Name); 6239 Set_Entity (Prefix (N), P_Name); 6240 end if; 6241 6242 if Present (Candidate) then 6243 6244 -- If we know that the unit is a child unit we can give a more 6245 -- accurate error message. 6246 6247 if Is_Child_Unit (Candidate) then 6248 6249 -- If the candidate is a private child unit and we are in 6250 -- the visible part of a public unit, specialize the error 6251 -- message. There might be a private with_clause for it, 6252 -- but it is not currently active. 6253 6254 if Is_Private_Descendant (Candidate) 6255 and then Ekind (Current_Scope) = E_Package 6256 and then not In_Private_Part (Current_Scope) 6257 and then not Is_Private_Descendant (Current_Scope) 6258 then 6259 Error_Msg_N 6260 ("private child unit& is not visible here", Selector); 6261 6262 -- Normal case where we have a missing with for a child unit 6263 6264 else 6265 Error_Msg_Qual_Level := 99; 6266 Error_Msg_NE -- CODEFIX 6267 ("missing `WITH &;`", Selector, Candidate); 6268 Error_Msg_Qual_Level := 0; 6269 end if; 6270 6271 -- Here we don't know that this is a child unit 6272 6273 else 6274 Error_Msg_NE ("& is not a visible entity of&", N, Selector); 6275 end if; 6276 6277 else 6278 -- Within the instantiation of a child unit, the prefix may 6279 -- denote the parent instance, but the selector has the name 6280 -- of the original child. That is to say, when A.B appears 6281 -- within an instantiation of generic child unit B, the scope 6282 -- stack includes an instance of A (P_Name) and an instance 6283 -- of B under some other name. We scan the scope to find this 6284 -- child instance, which is the desired entity. 6285 -- Note that the parent may itself be a child instance, if 6286 -- the reference is of the form A.B.C, in which case A.B has 6287 -- already been rewritten with the proper entity. 6288 6289 if In_Open_Scopes (P_Name) 6290 and then Is_Generic_Instance (P_Name) 6291 then 6292 declare 6293 Gen_Par : constant Entity_Id := 6294 Generic_Parent (Specification 6295 (Unit_Declaration_Node (P_Name))); 6296 S : Entity_Id := Current_Scope; 6297 P : Entity_Id; 6298 6299 begin 6300 for J in reverse 0 .. Scope_Stack.Last loop 6301 S := Scope_Stack.Table (J).Entity; 6302 6303 exit when S = Standard_Standard; 6304 6305 if Ekind_In (S, E_Function, 6306 E_Package, 6307 E_Procedure) 6308 then 6309 P := 6310 Generic_Parent (Specification 6311 (Unit_Declaration_Node (S))); 6312 6313 -- Check that P is a generic child of the generic 6314 -- parent of the prefix. 6315 6316 if Present (P) 6317 and then Chars (P) = Chars (Selector) 6318 and then Scope (P) = Gen_Par 6319 then 6320 Id := S; 6321 goto Found; 6322 end if; 6323 end if; 6324 6325 end loop; 6326 end; 6327 end if; 6328 6329 -- If this is a selection from Ada, System or Interfaces, then 6330 -- we assume a missing with for the corresponding package. 6331 6332 if Is_Known_Unit (N) then 6333 if not Error_Posted (N) then 6334 Error_Msg_Node_2 := Selector; 6335 Error_Msg_N -- CODEFIX 6336 ("missing `WITH &.&;`", Prefix (N)); 6337 end if; 6338 6339 -- If this is a selection from a dummy package, then suppress 6340 -- the error message, of course the entity is missing if the 6341 -- package is missing. 6342 6343 elsif Sloc (Error_Msg_Node_2) = No_Location then 6344 null; 6345 6346 -- Here we have the case of an undefined component 6347 6348 else 6349 -- The prefix may hide a homonym in the context that 6350 -- declares the desired entity. This error can use a 6351 -- specialized message. 6352 6353 if In_Open_Scopes (P_Name) then 6354 declare 6355 H : constant Entity_Id := Homonym (P_Name); 6356 6357 begin 6358 if Present (H) 6359 and then Is_Compilation_Unit (H) 6360 and then 6361 (Is_Immediately_Visible (H) 6362 or else Is_Visible_Lib_Unit (H)) 6363 then 6364 Id := First_Entity (H); 6365 while Present (Id) loop 6366 if Chars (Id) = Chars (Selector) then 6367 Error_Msg_Qual_Level := 99; 6368 Error_Msg_Name_1 := Chars (Selector); 6369 Error_Msg_NE 6370 ("% not declared in&", N, P_Name); 6371 Error_Msg_NE 6372 ("\use fully qualified name starting with " 6373 & "Standard to make& visible", N, H); 6374 Error_Msg_Qual_Level := 0; 6375 goto Done; 6376 end if; 6377 6378 Next_Entity (Id); 6379 end loop; 6380 end if; 6381 6382 -- If not found, standard error message 6383 6384 Error_Msg_NE ("& not declared in&", N, Selector); 6385 6386 <<Done>> null; 6387 end; 6388 6389 else 6390 -- Might be worth specializing the case when the prefix 6391 -- is a limited view. 6392 -- ... not declared in limited view of... 6393 6394 Error_Msg_NE ("& not declared in&", N, Selector); 6395 end if; 6396 6397 -- Check for misspelling of some entity in prefix 6398 6399 Id := First_Entity (P_Name); 6400 while Present (Id) loop 6401 if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector)) 6402 and then not Is_Internal_Name (Chars (Id)) 6403 then 6404 Error_Msg_NE -- CODEFIX 6405 ("possible misspelling of&", Selector, Id); 6406 exit; 6407 end if; 6408 6409 Next_Entity (Id); 6410 end loop; 6411 6412 -- Specialize the message if this may be an instantiation 6413 -- of a child unit that was not mentioned in the context. 6414 6415 if Nkind (Parent (N)) = N_Package_Instantiation 6416 and then Is_Generic_Instance (Entity (Prefix (N))) 6417 and then Is_Compilation_Unit 6418 (Generic_Parent (Parent (Entity (Prefix (N))))) 6419 then 6420 Error_Msg_Node_2 := Selector; 6421 Error_Msg_N -- CODEFIX 6422 ("\missing `WITH &.&;`", Prefix (N)); 6423 end if; 6424 end if; 6425 end if; 6426 6427 Id := Any_Id; 6428 end if; 6429 end if; 6430 6431 <<Found>> 6432 if Comes_From_Source (N) 6433 and then Is_Remote_Access_To_Subprogram_Type (Id) 6434 and then Ekind (Id) = E_Access_Subprogram_Type 6435 and then Present (Equivalent_Type (Id)) 6436 then 6437 -- If we are not actually generating distribution code (i.e. the 6438 -- current PCS is the dummy non-distributed version), then the 6439 -- Equivalent_Type will be missing, and Id should be treated as 6440 -- a regular access-to-subprogram type. 6441 6442 Id := Equivalent_Type (Id); 6443 Set_Chars (Selector, Chars (Id)); 6444 end if; 6445 6446 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units 6447 6448 if Ekind (P_Name) = E_Package and then From_Limited_With (P_Name) then 6449 if From_Limited_With (Id) 6450 or else Is_Type (Id) 6451 or else Ekind (Id) = E_Package 6452 then 6453 null; 6454 else 6455 Error_Msg_N 6456 ("limited withed package can only be used to access incomplete " 6457 & "types", N); 6458 end if; 6459 end if; 6460 6461 if Is_Task_Type (P_Name) 6462 and then ((Ekind (Id) = E_Entry 6463 and then Nkind (Parent (N)) /= N_Attribute_Reference) 6464 or else 6465 (Ekind (Id) = E_Entry_Family 6466 and then 6467 Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) 6468 then 6469 -- If both the task type and the entry are in scope, this may still 6470 -- be the expanded name of an entry formal. 6471 6472 if In_Open_Scopes (Id) 6473 and then Nkind (Parent (N)) = N_Selected_Component 6474 then 6475 null; 6476 6477 else 6478 -- It is an entry call after all, either to the current task 6479 -- (which will deadlock) or to an enclosing task. 6480 6481 Analyze_Selected_Component (N); 6482 return; 6483 end if; 6484 end if; 6485 6486 Change_Selected_Component_To_Expanded_Name (N); 6487 6488 -- Preserve relevant elaboration-related attributes of the context which 6489 -- are no longer available or very expensive to recompute once analysis, 6490 -- resolution, and expansion are over. 6491 6492 Mark_Elaboration_Attributes 6493 (N_Id => N, 6494 Modes => True); 6495 6496 -- Set appropriate type 6497 6498 if Is_Type (Id) then 6499 Set_Etype (N, Id); 6500 else 6501 Set_Etype (N, Get_Full_View (Etype (Id))); 6502 end if; 6503 6504 -- Do style check and generate reference, but skip both steps if this 6505 -- entity has homonyms, since we may not have the right homonym set yet. 6506 -- The proper homonym will be set during the resolve phase. 6507 6508 if Has_Homonym (Id) then 6509 Set_Entity (N, Id); 6510 6511 else 6512 Set_Entity_Or_Discriminal (N, Id); 6513 6514 case Is_LHS (N) is 6515 when Yes => 6516 Generate_Reference (Id, N, 'm'); 6517 6518 when No => 6519 Generate_Reference (Id, N, 'r'); 6520 6521 when Unknown => 6522 Deferred_References.Append ((Id, N)); 6523 end case; 6524 end if; 6525 6526 -- Check for violation of No_Wide_Characters 6527 6528 Check_Wide_Character_Restriction (Id, N); 6529 6530 -- If the Ekind of the entity is Void, it means that all homonyms are 6531 -- hidden from all visibility (RM 8.3(5,14-20)). 6532 6533 if Ekind (Id) = E_Void then 6534 Premature_Usage (N); 6535 6536 elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then 6537 declare 6538 H : Entity_Id := Homonym (Id); 6539 6540 begin 6541 while Present (H) loop 6542 if Scope (H) = Scope (Id) 6543 and then (not Is_Hidden (H) 6544 or else Is_Immediately_Visible (H)) 6545 then 6546 Collect_Interps (N); 6547 exit; 6548 end if; 6549 6550 H := Homonym (H); 6551 end loop; 6552 6553 -- If an extension of System is present, collect possible explicit 6554 -- overloadings declared in the extension. 6555 6556 if Chars (P_Name) = Name_System 6557 and then Scope (P_Name) = Standard_Standard 6558 and then Present (System_Extend_Unit) 6559 and then Present_System_Aux (N) 6560 then 6561 H := Current_Entity (Id); 6562 6563 while Present (H) loop 6564 if Scope (H) = System_Aux_Id then 6565 Add_One_Interp (N, H, Etype (H)); 6566 end if; 6567 6568 H := Homonym (H); 6569 end loop; 6570 end if; 6571 end; 6572 end if; 6573 6574 if Nkind (Selector_Name (N)) = N_Operator_Symbol 6575 and then Scope (Id) /= Standard_Standard 6576 then 6577 -- In addition to user-defined operators in the given scope, there 6578 -- may be an implicit instance of the predefined operator. The 6579 -- operator (defined in Standard) is found in Has_Implicit_Operator, 6580 -- and added to the interpretations. Procedure Add_One_Interp will 6581 -- determine which hides which. 6582 6583 if Has_Implicit_Operator (N) then 6584 null; 6585 end if; 6586 end if; 6587 6588 -- If there is a single interpretation for N we can generate a 6589 -- reference to the unique entity found. 6590 6591 if Is_Overloadable (Id) and then not Is_Overloaded (N) then 6592 Generate_Reference (Id, N); 6593 end if; 6594 6595 -- Mark relevant use-type and use-package clauses as effective if the 6596 -- node in question is not overloaded and therefore does not require 6597 -- resolution. 6598 6599 if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then 6600 Mark_Use_Clauses (N); 6601 end if; 6602 6603 Check_Restriction_No_Use_Of_Entity (N); 6604 6605 -- Annotate the tree by creating a variable reference marker in case the 6606 -- original variable reference is folded or optimized away. The variable 6607 -- reference marker is automatically saved for later examination by the 6608 -- ABE Processing phase. Variable references which act as actuals in a 6609 -- call require special processing and are left to Resolve_Actuals. The 6610 -- reference is a write when it appears on the left hand side of an 6611 -- assignment. 6612 6613 if not Within_Subprogram_Call (N) then 6614 Build_Variable_Reference_Marker 6615 (N => N, 6616 Read => not Is_Assignment_LHS, 6617 Write => Is_Assignment_LHS); 6618 end if; 6619 end Find_Expanded_Name; 6620 6621 -------------------- 6622 -- Find_Most_Prev -- 6623 -------------------- 6624 6625 function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is 6626 Curr : Node_Id; 6627 6628 begin 6629 -- Loop through the Prev_Use_Clause chain 6630 6631 Curr := Use_Clause; 6632 while Present (Prev_Use_Clause (Curr)) loop 6633 Curr := Prev_Use_Clause (Curr); 6634 end loop; 6635 6636 return Curr; 6637 end Find_Most_Prev; 6638 6639 ------------------------- 6640 -- Find_Renamed_Entity -- 6641 ------------------------- 6642 6643 function Find_Renamed_Entity 6644 (N : Node_Id; 6645 Nam : Node_Id; 6646 New_S : Entity_Id; 6647 Is_Actual : Boolean := False) return Entity_Id 6648 is 6649 Ind : Interp_Index; 6650 I1 : Interp_Index := 0; -- Suppress junk warnings 6651 It : Interp; 6652 It1 : Interp; 6653 Old_S : Entity_Id; 6654 Inst : Entity_Id; 6655 6656 function Is_Visible_Operation (Op : Entity_Id) return Boolean; 6657 -- If the renamed entity is an implicit operator, check whether it is 6658 -- visible because its operand type is properly visible. This check 6659 -- applies to explicit renamed entities that appear in the source in a 6660 -- renaming declaration or a formal subprogram instance, but not to 6661 -- default generic actuals with a name. 6662 6663 function Report_Overload return Entity_Id; 6664 -- List possible interpretations, and specialize message in the 6665 -- case of a generic actual. 6666 6667 function Within (Inner, Outer : Entity_Id) return Boolean; 6668 -- Determine whether a candidate subprogram is defined within the 6669 -- enclosing instance. If yes, it has precedence over outer candidates. 6670 6671 -------------------------- 6672 -- Is_Visible_Operation -- 6673 -------------------------- 6674 6675 function Is_Visible_Operation (Op : Entity_Id) return Boolean is 6676 Scop : Entity_Id; 6677 Typ : Entity_Id; 6678 Btyp : Entity_Id; 6679 6680 begin 6681 if Ekind (Op) /= E_Operator 6682 or else Scope (Op) /= Standard_Standard 6683 or else (In_Instance 6684 and then (not Is_Actual 6685 or else Present (Enclosing_Instance))) 6686 then 6687 return True; 6688 6689 else 6690 -- For a fixed point type operator, check the resulting type, 6691 -- because it may be a mixed mode integer * fixed operation. 6692 6693 if Present (Next_Formal (First_Formal (New_S))) 6694 and then Is_Fixed_Point_Type (Etype (New_S)) 6695 then 6696 Typ := Etype (New_S); 6697 else 6698 Typ := Etype (First_Formal (New_S)); 6699 end if; 6700 6701 Btyp := Base_Type (Typ); 6702 6703 if Nkind (Nam) /= N_Expanded_Name then 6704 return (In_Open_Scopes (Scope (Btyp)) 6705 or else Is_Potentially_Use_Visible (Btyp) 6706 or else In_Use (Btyp) 6707 or else In_Use (Scope (Btyp))); 6708 6709 else 6710 Scop := Entity (Prefix (Nam)); 6711 6712 if Ekind (Scop) = E_Package 6713 and then Present (Renamed_Object (Scop)) 6714 then 6715 Scop := Renamed_Object (Scop); 6716 end if; 6717 6718 -- Operator is visible if prefix of expanded name denotes 6719 -- scope of type, or else type is defined in System_Aux 6720 -- and the prefix denotes System. 6721 6722 return Scope (Btyp) = Scop 6723 or else (Scope (Btyp) = System_Aux_Id 6724 and then Scope (Scope (Btyp)) = Scop); 6725 end if; 6726 end if; 6727 end Is_Visible_Operation; 6728 6729 ------------ 6730 -- Within -- 6731 ------------ 6732 6733 function Within (Inner, Outer : Entity_Id) return Boolean is 6734 Sc : Entity_Id; 6735 6736 begin 6737 Sc := Scope (Inner); 6738 while Sc /= Standard_Standard loop 6739 if Sc = Outer then 6740 return True; 6741 else 6742 Sc := Scope (Sc); 6743 end if; 6744 end loop; 6745 6746 return False; 6747 end Within; 6748 6749 --------------------- 6750 -- Report_Overload -- 6751 --------------------- 6752 6753 function Report_Overload return Entity_Id is 6754 begin 6755 if Is_Actual then 6756 Error_Msg_NE -- CODEFIX 6757 ("ambiguous actual subprogram&, " & 6758 "possible interpretations:", N, Nam); 6759 else 6760 Error_Msg_N -- CODEFIX 6761 ("ambiguous subprogram, " & 6762 "possible interpretations:", N); 6763 end if; 6764 6765 List_Interps (Nam, N); 6766 return Old_S; 6767 end Report_Overload; 6768 6769 -- Start of processing for Find_Renamed_Entity 6770 6771 begin 6772 Old_S := Any_Id; 6773 Candidate_Renaming := Empty; 6774 6775 if Is_Overloaded (Nam) then 6776 Get_First_Interp (Nam, Ind, It); 6777 while Present (It.Nam) loop 6778 if Entity_Matches_Spec (It.Nam, New_S) 6779 and then Is_Visible_Operation (It.Nam) 6780 then 6781 if Old_S /= Any_Id then 6782 6783 -- Note: The call to Disambiguate only happens if a 6784 -- previous interpretation was found, in which case I1 6785 -- has received a value. 6786 6787 It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S)); 6788 6789 if It1 = No_Interp then 6790 Inst := Enclosing_Instance; 6791 6792 if Present (Inst) then 6793 if Within (It.Nam, Inst) then 6794 if Within (Old_S, Inst) then 6795 6796 -- Choose the innermost subprogram, which would 6797 -- have hidden the outer one in the generic. 6798 6799 if Scope_Depth (It.Nam) < 6800 Scope_Depth (Old_S) 6801 then 6802 return Old_S; 6803 else 6804 return It.Nam; 6805 end if; 6806 end if; 6807 6808 elsif Within (Old_S, Inst) then 6809 return (Old_S); 6810 6811 else 6812 return Report_Overload; 6813 end if; 6814 6815 -- If not within an instance, ambiguity is real 6816 6817 else 6818 return Report_Overload; 6819 end if; 6820 6821 else 6822 Old_S := It1.Nam; 6823 exit; 6824 end if; 6825 6826 else 6827 I1 := Ind; 6828 Old_S := It.Nam; 6829 end if; 6830 6831 elsif 6832 Present (First_Formal (It.Nam)) 6833 and then Present (First_Formal (New_S)) 6834 and then (Base_Type (Etype (First_Formal (It.Nam))) = 6835 Base_Type (Etype (First_Formal (New_S)))) 6836 then 6837 Candidate_Renaming := It.Nam; 6838 end if; 6839 6840 Get_Next_Interp (Ind, It); 6841 end loop; 6842 6843 Set_Entity (Nam, Old_S); 6844 6845 if Old_S /= Any_Id then 6846 Set_Is_Overloaded (Nam, False); 6847 end if; 6848 6849 -- Non-overloaded case 6850 6851 else 6852 if Is_Actual 6853 and then Present (Enclosing_Instance) 6854 and then Entity_Matches_Spec (Entity (Nam), New_S) 6855 then 6856 Old_S := Entity (Nam); 6857 6858 elsif Entity_Matches_Spec (Entity (Nam), New_S) then 6859 Candidate_Renaming := New_S; 6860 6861 if Is_Visible_Operation (Entity (Nam)) then 6862 Old_S := Entity (Nam); 6863 end if; 6864 6865 elsif Present (First_Formal (Entity (Nam))) 6866 and then Present (First_Formal (New_S)) 6867 and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = 6868 Base_Type (Etype (First_Formal (New_S)))) 6869 then 6870 Candidate_Renaming := Entity (Nam); 6871 end if; 6872 end if; 6873 6874 return Old_S; 6875 end Find_Renamed_Entity; 6876 6877 ----------------------------- 6878 -- Find_Selected_Component -- 6879 ----------------------------- 6880 6881 procedure Find_Selected_Component (N : Node_Id) is 6882 P : constant Node_Id := Prefix (N); 6883 6884 P_Name : Entity_Id; 6885 -- Entity denoted by prefix 6886 6887 P_Type : Entity_Id; 6888 -- and its type 6889 6890 Nam : Node_Id; 6891 6892 function Available_Subtype return Boolean; 6893 -- A small optimization: if the prefix is constrained and the component 6894 -- is an array type we may already have a usable subtype for it, so we 6895 -- can use it rather than generating a new one, because the bounds 6896 -- will be the values of the discriminants and not discriminant refs. 6897 -- This simplifies value tracing in GNATProve. For consistency, both 6898 -- the entity name and the subtype come from the constrained component. 6899 6900 -- This is only used in GNATProve mode: when generating code it may be 6901 -- necessary to create an itype in the scope of use of the selected 6902 -- component, e.g. in the context of a expanded record equality. 6903 6904 function Is_Reference_In_Subunit return Boolean; 6905 -- In a subunit, the scope depth is not a proper measure of hiding, 6906 -- because the context of the proper body may itself hide entities in 6907 -- parent units. This rare case requires inspecting the tree directly 6908 -- because the proper body is inserted in the main unit and its context 6909 -- is simply added to that of the parent. 6910 6911 ----------------------- 6912 -- Available_Subtype -- 6913 ----------------------- 6914 6915 function Available_Subtype return Boolean is 6916 Comp : Entity_Id; 6917 6918 begin 6919 if GNATprove_Mode then 6920 Comp := First_Entity (Etype (P)); 6921 while Present (Comp) loop 6922 if Chars (Comp) = Chars (Selector_Name (N)) then 6923 Set_Etype (N, Etype (Comp)); 6924 Set_Entity (Selector_Name (N), Comp); 6925 Set_Etype (Selector_Name (N), Etype (Comp)); 6926 return True; 6927 end if; 6928 6929 Next_Component (Comp); 6930 end loop; 6931 end if; 6932 6933 return False; 6934 end Available_Subtype; 6935 6936 ----------------------------- 6937 -- Is_Reference_In_Subunit -- 6938 ----------------------------- 6939 6940 function Is_Reference_In_Subunit return Boolean is 6941 Clause : Node_Id; 6942 Comp_Unit : Node_Id; 6943 6944 begin 6945 Comp_Unit := N; 6946 while Present (Comp_Unit) 6947 and then Nkind (Comp_Unit) /= N_Compilation_Unit 6948 loop 6949 Comp_Unit := Parent (Comp_Unit); 6950 end loop; 6951 6952 if No (Comp_Unit) or else Nkind (Unit (Comp_Unit)) /= N_Subunit then 6953 return False; 6954 end if; 6955 6956 -- Now check whether the package is in the context of the subunit 6957 6958 Clause := First (Context_Items (Comp_Unit)); 6959 while Present (Clause) loop 6960 if Nkind (Clause) = N_With_Clause 6961 and then Entity (Name (Clause)) = P_Name 6962 then 6963 return True; 6964 end if; 6965 6966 Clause := Next (Clause); 6967 end loop; 6968 6969 return False; 6970 end Is_Reference_In_Subunit; 6971 6972 -- Start of processing for Find_Selected_Component 6973 6974 begin 6975 Analyze (P); 6976 6977 if Nkind (P) = N_Error then 6978 return; 6979 end if; 6980 6981 -- Selector name cannot be a character literal or an operator symbol in 6982 -- SPARK, except for the operator symbol in a renaming. 6983 6984 if Restriction_Check_Required (SPARK_05) then 6985 if Nkind (Selector_Name (N)) = N_Character_Literal then 6986 Check_SPARK_05_Restriction 6987 ("character literal cannot be prefixed", N); 6988 elsif Nkind (Selector_Name (N)) = N_Operator_Symbol 6989 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration 6990 then 6991 Check_SPARK_05_Restriction 6992 ("operator symbol cannot be prefixed", N); 6993 end if; 6994 end if; 6995 6996 -- If the selector already has an entity, the node has been constructed 6997 -- in the course of expansion, and is known to be valid. Do not verify 6998 -- that it is defined for the type (it may be a private component used 6999 -- in the expansion of record equality). 7000 7001 if Present (Entity (Selector_Name (N))) then 7002 if No (Etype (N)) or else Etype (N) = Any_Type then 7003 declare 7004 Sel_Name : constant Node_Id := Selector_Name (N); 7005 Selector : constant Entity_Id := Entity (Sel_Name); 7006 C_Etype : Node_Id; 7007 7008 begin 7009 Set_Etype (Sel_Name, Etype (Selector)); 7010 7011 if not Is_Entity_Name (P) then 7012 Resolve (P); 7013 end if; 7014 7015 -- Build an actual subtype except for the first parameter 7016 -- of an init proc, where this actual subtype is by 7017 -- definition incorrect, since the object is uninitialized 7018 -- (and does not even have defined discriminants etc.) 7019 7020 if Is_Entity_Name (P) 7021 and then Ekind (Entity (P)) = E_Function 7022 then 7023 Nam := New_Copy (P); 7024 7025 if Is_Overloaded (P) then 7026 Save_Interps (P, Nam); 7027 end if; 7028 7029 Rewrite (P, Make_Function_Call (Sloc (P), Name => Nam)); 7030 Analyze_Call (P); 7031 Analyze_Selected_Component (N); 7032 return; 7033 7034 elsif Ekind (Selector) = E_Component 7035 and then (not Is_Entity_Name (P) 7036 or else Chars (Entity (P)) /= Name_uInit) 7037 then 7038 -- Check if we already have an available subtype we can use 7039 7040 if Ekind (Etype (P)) = E_Record_Subtype 7041 and then Nkind (Parent (Etype (P))) = N_Subtype_Declaration 7042 and then Is_Array_Type (Etype (Selector)) 7043 and then not Is_Packed (Etype (Selector)) 7044 and then Available_Subtype 7045 then 7046 return; 7047 7048 -- Do not build the subtype when referencing components of 7049 -- dispatch table wrappers. Required to avoid generating 7050 -- elaboration code with HI runtimes. 7051 7052 elsif RTU_Loaded (Ada_Tags) 7053 and then 7054 ((RTE_Available (RE_Dispatch_Table_Wrapper) 7055 and then Scope (Selector) = 7056 RTE (RE_Dispatch_Table_Wrapper)) 7057 or else 7058 (RTE_Available (RE_No_Dispatch_Table_Wrapper) 7059 and then Scope (Selector) = 7060 RTE (RE_No_Dispatch_Table_Wrapper))) 7061 then 7062 C_Etype := Empty; 7063 else 7064 C_Etype := 7065 Build_Actual_Subtype_Of_Component 7066 (Etype (Selector), N); 7067 end if; 7068 7069 else 7070 C_Etype := Empty; 7071 end if; 7072 7073 if No (C_Etype) then 7074 C_Etype := Etype (Selector); 7075 else 7076 Insert_Action (N, C_Etype); 7077 C_Etype := Defining_Identifier (C_Etype); 7078 end if; 7079 7080 Set_Etype (N, C_Etype); 7081 end; 7082 7083 -- If this is the name of an entry or protected operation, and 7084 -- the prefix is an access type, insert an explicit dereference, 7085 -- so that entry calls are treated uniformly. 7086 7087 if Is_Access_Type (Etype (P)) 7088 and then Is_Concurrent_Type (Designated_Type (Etype (P))) 7089 then 7090 declare 7091 New_P : constant Node_Id := 7092 Make_Explicit_Dereference (Sloc (P), 7093 Prefix => Relocate_Node (P)); 7094 begin 7095 Rewrite (P, New_P); 7096 Set_Etype (P, Designated_Type (Etype (Prefix (P)))); 7097 end; 7098 end if; 7099 7100 -- If the selected component appears within a default expression 7101 -- and it has an actual subtype, the pre-analysis has not yet 7102 -- completed its analysis, because Insert_Actions is disabled in 7103 -- that context. Within the init proc of the enclosing type we 7104 -- must complete this analysis, if an actual subtype was created. 7105 7106 elsif Inside_Init_Proc then 7107 declare 7108 Typ : constant Entity_Id := Etype (N); 7109 Decl : constant Node_Id := Declaration_Node (Typ); 7110 begin 7111 if Nkind (Decl) = N_Subtype_Declaration 7112 and then not Analyzed (Decl) 7113 and then Is_List_Member (Decl) 7114 and then No (Parent (Decl)) 7115 then 7116 Remove (Decl); 7117 Insert_Action (N, Decl); 7118 end if; 7119 end; 7120 end if; 7121 7122 return; 7123 7124 elsif Is_Entity_Name (P) then 7125 P_Name := Entity (P); 7126 7127 -- The prefix may denote an enclosing type which is the completion 7128 -- of an incomplete type declaration. 7129 7130 if Is_Type (P_Name) then 7131 Set_Entity (P, Get_Full_View (P_Name)); 7132 Set_Etype (P, Entity (P)); 7133 P_Name := Entity (P); 7134 end if; 7135 7136 P_Type := Base_Type (Etype (P)); 7137 7138 if Debug_Flag_E then 7139 Write_Str ("Found prefix type to be "); 7140 Write_Entity_Info (P_Type, " "); Write_Eol; 7141 end if; 7142 7143 -- The designated type may be a limited view with no components. 7144 -- Check whether the non-limited view is available, because in some 7145 -- cases this will not be set when installing the context. Rewrite 7146 -- the node by introducing an explicit dereference at once, and 7147 -- setting the type of the rewritten prefix to the non-limited view 7148 -- of the original designated type. 7149 7150 if Is_Access_Type (P_Type) then 7151 declare 7152 Desig_Typ : constant Entity_Id := 7153 Directly_Designated_Type (P_Type); 7154 7155 begin 7156 if Is_Incomplete_Type (Desig_Typ) 7157 and then From_Limited_With (Desig_Typ) 7158 and then Present (Non_Limited_View (Desig_Typ)) 7159 then 7160 Rewrite (P, 7161 Make_Explicit_Dereference (Sloc (P), 7162 Prefix => Relocate_Node (P))); 7163 7164 Set_Etype (P, Get_Full_View (Non_Limited_View (Desig_Typ))); 7165 P_Type := Etype (P); 7166 end if; 7167 end; 7168 end if; 7169 7170 -- First check for components of a record object (not the 7171 -- result of a call, which is handled below). 7172 7173 if Is_Appropriate_For_Record (P_Type) 7174 and then not Is_Overloadable (P_Name) 7175 and then not Is_Type (P_Name) 7176 then 7177 -- Selected component of record. Type checking will validate 7178 -- name of selector. 7179 7180 -- ??? Could we rewrite an implicit dereference into an explicit 7181 -- one here? 7182 7183 Analyze_Selected_Component (N); 7184 7185 -- Reference to type name in predicate/invariant expression 7186 7187 elsif Is_Appropriate_For_Entry_Prefix (P_Type) 7188 and then not In_Open_Scopes (P_Name) 7189 and then (not Is_Concurrent_Type (Etype (P_Name)) 7190 or else not In_Open_Scopes (Etype (P_Name))) 7191 then 7192 -- Call to protected operation or entry. Type checking is 7193 -- needed on the prefix. 7194 7195 Analyze_Selected_Component (N); 7196 7197 elsif (In_Open_Scopes (P_Name) 7198 and then Ekind (P_Name) /= E_Void 7199 and then not Is_Overloadable (P_Name)) 7200 or else (Is_Concurrent_Type (Etype (P_Name)) 7201 and then In_Open_Scopes (Etype (P_Name))) 7202 then 7203 -- Prefix denotes an enclosing loop, block, or task, i.e. an 7204 -- enclosing construct that is not a subprogram or accept. 7205 7206 -- A special case: a protected body may call an operation 7207 -- on an external object of the same type, in which case it 7208 -- is not an expanded name. If the prefix is the type itself, 7209 -- or the context is a single synchronized object it can only 7210 -- be interpreted as an expanded name. 7211 7212 if Is_Concurrent_Type (Etype (P_Name)) then 7213 if Is_Type (P_Name) 7214 or else Present (Anonymous_Object (Etype (P_Name))) 7215 then 7216 Find_Expanded_Name (N); 7217 7218 else 7219 Analyze_Selected_Component (N); 7220 return; 7221 end if; 7222 7223 else 7224 Find_Expanded_Name (N); 7225 end if; 7226 7227 elsif Ekind (P_Name) = E_Package then 7228 Find_Expanded_Name (N); 7229 7230 elsif Is_Overloadable (P_Name) then 7231 7232 -- The subprogram may be a renaming (of an enclosing scope) as 7233 -- in the case of the name of the generic within an instantiation. 7234 7235 if Ekind_In (P_Name, E_Procedure, E_Function) 7236 and then Present (Alias (P_Name)) 7237 and then Is_Generic_Instance (Alias (P_Name)) 7238 then 7239 P_Name := Alias (P_Name); 7240 end if; 7241 7242 if Is_Overloaded (P) then 7243 7244 -- The prefix must resolve to a unique enclosing construct 7245 7246 declare 7247 Found : Boolean := False; 7248 Ind : Interp_Index; 7249 It : Interp; 7250 7251 begin 7252 Get_First_Interp (P, Ind, It); 7253 while Present (It.Nam) loop 7254 if In_Open_Scopes (It.Nam) then 7255 if Found then 7256 Error_Msg_N ( 7257 "prefix must be unique enclosing scope", N); 7258 Set_Entity (N, Any_Id); 7259 Set_Etype (N, Any_Type); 7260 return; 7261 7262 else 7263 Found := True; 7264 P_Name := It.Nam; 7265 end if; 7266 end if; 7267 7268 Get_Next_Interp (Ind, It); 7269 end loop; 7270 end; 7271 end if; 7272 7273 if In_Open_Scopes (P_Name) then 7274 Set_Entity (P, P_Name); 7275 Set_Is_Overloaded (P, False); 7276 Find_Expanded_Name (N); 7277 7278 else 7279 -- If no interpretation as an expanded name is possible, it 7280 -- must be a selected component of a record returned by a 7281 -- function call. Reformat prefix as a function call, the rest 7282 -- is done by type resolution. 7283 7284 -- Error if the prefix is procedure or entry, as is P.X 7285 7286 if Ekind (P_Name) /= E_Function 7287 and then 7288 (not Is_Overloaded (P) 7289 or else Nkind (Parent (N)) = N_Procedure_Call_Statement) 7290 then 7291 -- Prefix may mention a package that is hidden by a local 7292 -- declaration: let the user know. Scan the full homonym 7293 -- chain, the candidate package may be anywhere on it. 7294 7295 if Present (Homonym (Current_Entity (P_Name))) then 7296 P_Name := Current_Entity (P_Name); 7297 7298 while Present (P_Name) loop 7299 exit when Ekind (P_Name) = E_Package; 7300 P_Name := Homonym (P_Name); 7301 end loop; 7302 7303 if Present (P_Name) then 7304 if not Is_Reference_In_Subunit then 7305 Error_Msg_Sloc := Sloc (Entity (Prefix (N))); 7306 Error_Msg_NE 7307 ("package& is hidden by declaration#", N, P_Name); 7308 end if; 7309 7310 Set_Entity (Prefix (N), P_Name); 7311 Find_Expanded_Name (N); 7312 return; 7313 7314 else 7315 P_Name := Entity (Prefix (N)); 7316 end if; 7317 end if; 7318 7319 Error_Msg_NE 7320 ("invalid prefix in selected component&", N, P_Name); 7321 Change_Selected_Component_To_Expanded_Name (N); 7322 Set_Entity (N, Any_Id); 7323 Set_Etype (N, Any_Type); 7324 7325 -- Here we have a function call, so do the reformatting 7326 7327 else 7328 Nam := New_Copy (P); 7329 Save_Interps (P, Nam); 7330 7331 -- We use Replace here because this is one of those cases 7332 -- where the parser has missclassified the node, and we fix 7333 -- things up and then do the semantic analysis on the fixed 7334 -- up node. Normally we do this using one of the Sinfo.CN 7335 -- routines, but this is too tricky for that. 7336 7337 -- Note that using Rewrite would be wrong, because we would 7338 -- have a tree where the original node is unanalyzed, and 7339 -- this violates the required interface for ASIS. 7340 7341 Replace (P, 7342 Make_Function_Call (Sloc (P), Name => Nam)); 7343 7344 -- Now analyze the reformatted node 7345 7346 Analyze_Call (P); 7347 7348 -- If the prefix is illegal after this transformation, there 7349 -- may be visibility errors on the prefix. The safest is to 7350 -- treat the selected component as an error. 7351 7352 if Error_Posted (P) then 7353 Set_Etype (N, Any_Type); 7354 return; 7355 7356 else 7357 Analyze_Selected_Component (N); 7358 end if; 7359 end if; 7360 end if; 7361 7362 -- Remaining cases generate various error messages 7363 7364 else 7365 -- Format node as expanded name, to avoid cascaded errors 7366 7367 -- If the limited_with transformation was applied earlier, restore 7368 -- source for proper error reporting. 7369 7370 if not Comes_From_Source (P) 7371 and then Nkind (P) = N_Explicit_Dereference 7372 then 7373 Rewrite (P, Prefix (P)); 7374 P_Type := Etype (P); 7375 end if; 7376 7377 Change_Selected_Component_To_Expanded_Name (N); 7378 Set_Entity (N, Any_Id); 7379 Set_Etype (N, Any_Type); 7380 7381 -- Issue error message, but avoid this if error issued already. 7382 -- Use identifier of prefix if one is available. 7383 7384 if P_Name = Any_Id then 7385 null; 7386 7387 -- It is not an error if the prefix is the current instance of 7388 -- type name, e.g. the expression of a type aspect, when it is 7389 -- analyzed for ASIS use. 7390 7391 elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then 7392 null; 7393 7394 elsif Ekind (P_Name) = E_Void then 7395 Premature_Usage (P); 7396 7397 elsif Nkind (P) /= N_Attribute_Reference then 7398 7399 -- This may have been meant as a prefixed call to a primitive 7400 -- of an untagged type. If it is a function call check type of 7401 -- its first formal and add explanation. 7402 7403 declare 7404 F : constant Entity_Id := 7405 Current_Entity (Selector_Name (N)); 7406 begin 7407 if Present (F) 7408 and then Is_Overloadable (F) 7409 and then Present (First_Entity (F)) 7410 and then not Is_Tagged_Type (Etype (First_Entity (F))) 7411 then 7412 Error_Msg_N 7413 ("prefixed call is only allowed for objects of a " 7414 & "tagged type", N); 7415 end if; 7416 end; 7417 7418 Error_Msg_N ("invalid prefix in selected component&", P); 7419 7420 if Is_Access_Type (P_Type) 7421 and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type 7422 then 7423 Error_Msg_N 7424 ("\dereference must not be of an incomplete type " 7425 & "(RM 3.10.1)", P); 7426 end if; 7427 7428 else 7429 Error_Msg_N ("invalid prefix in selected component", P); 7430 end if; 7431 end if; 7432 7433 -- Selector name is restricted in SPARK 7434 7435 if Nkind (N) = N_Expanded_Name 7436 and then Restriction_Check_Required (SPARK_05) 7437 then 7438 if Is_Subprogram (P_Name) then 7439 Check_SPARK_05_Restriction 7440 ("prefix of expanded name cannot be a subprogram", P); 7441 elsif Ekind (P_Name) = E_Loop then 7442 Check_SPARK_05_Restriction 7443 ("prefix of expanded name cannot be a loop statement", P); 7444 end if; 7445 end if; 7446 7447 else 7448 -- If prefix is not the name of an entity, it must be an expression, 7449 -- whose type is appropriate for a record. This is determined by 7450 -- type resolution. 7451 7452 Analyze_Selected_Component (N); 7453 end if; 7454 7455 Analyze_Dimension (N); 7456 end Find_Selected_Component; 7457 7458 --------------- 7459 -- Find_Type -- 7460 --------------- 7461 7462 procedure Find_Type (N : Node_Id) is 7463 C : Entity_Id; 7464 Typ : Entity_Id; 7465 T : Entity_Id; 7466 T_Name : Entity_Id; 7467 7468 begin 7469 if N = Error then 7470 return; 7471 7472 elsif Nkind (N) = N_Attribute_Reference then 7473 7474 -- Class attribute. This is not valid in Ada 83 mode, but we do not 7475 -- need to enforce that at this point, since the declaration of the 7476 -- tagged type in the prefix would have been flagged already. 7477 7478 if Attribute_Name (N) = Name_Class then 7479 Check_Restriction (No_Dispatch, N); 7480 Find_Type (Prefix (N)); 7481 7482 -- Propagate error from bad prefix 7483 7484 if Etype (Prefix (N)) = Any_Type then 7485 Set_Entity (N, Any_Type); 7486 Set_Etype (N, Any_Type); 7487 return; 7488 end if; 7489 7490 T := Base_Type (Entity (Prefix (N))); 7491 7492 -- Case where type is not known to be tagged. Its appearance in 7493 -- the prefix of the 'Class attribute indicates that the full view 7494 -- will be tagged. 7495 7496 if not Is_Tagged_Type (T) then 7497 if Ekind (T) = E_Incomplete_Type then 7498 7499 -- It is legal to denote the class type of an incomplete 7500 -- type. The full type will have to be tagged, of course. 7501 -- In Ada 2005 this usage is declared obsolescent, so we 7502 -- warn accordingly. This usage is only legal if the type 7503 -- is completed in the current scope, and not for a limited 7504 -- view of a type. 7505 7506 if Ada_Version >= Ada_2005 then 7507 7508 -- Test whether the Available_View of a limited type view 7509 -- is tagged, since the limited view may not be marked as 7510 -- tagged if the type itself has an untagged incomplete 7511 -- type view in its package. 7512 7513 if From_Limited_With (T) 7514 and then not Is_Tagged_Type (Available_View (T)) 7515 then 7516 Error_Msg_N 7517 ("prefix of Class attribute must be tagged", N); 7518 Set_Etype (N, Any_Type); 7519 Set_Entity (N, Any_Type); 7520 return; 7521 7522 -- ??? This test is temporarily disabled (always 7523 -- False) because it causes an unwanted warning on 7524 -- GNAT sources (built with -gnatg, which includes 7525 -- Warn_On_Obsolescent_ Feature). Once this issue 7526 -- is cleared in the sources, it can be enabled. 7527 7528 elsif Warn_On_Obsolescent_Feature and then False then 7529 Error_Msg_N 7530 ("applying 'Class to an untagged incomplete type" 7531 & " is an obsolescent feature (RM J.11)?r?", N); 7532 end if; 7533 end if; 7534 7535 Set_Is_Tagged_Type (T); 7536 Set_Direct_Primitive_Operations (T, New_Elmt_List); 7537 Make_Class_Wide_Type (T); 7538 Set_Entity (N, Class_Wide_Type (T)); 7539 Set_Etype (N, Class_Wide_Type (T)); 7540 7541 elsif Ekind (T) = E_Private_Type 7542 and then not Is_Generic_Type (T) 7543 and then In_Private_Part (Scope (T)) 7544 then 7545 -- The Class attribute can be applied to an untagged private 7546 -- type fulfilled by a tagged type prior to the full type 7547 -- declaration (but only within the parent package's private 7548 -- part). Create the class-wide type now and check that the 7549 -- full type is tagged later during its analysis. Note that 7550 -- we do not mark the private type as tagged, unlike the 7551 -- case of incomplete types, because the type must still 7552 -- appear untagged to outside units. 7553 7554 if No (Class_Wide_Type (T)) then 7555 Make_Class_Wide_Type (T); 7556 end if; 7557 7558 Set_Entity (N, Class_Wide_Type (T)); 7559 Set_Etype (N, Class_Wide_Type (T)); 7560 7561 else 7562 -- Should we introduce a type Any_Tagged and use Wrong_Type 7563 -- here, it would be a bit more consistent??? 7564 7565 Error_Msg_NE 7566 ("tagged type required, found}", 7567 Prefix (N), First_Subtype (T)); 7568 Set_Entity (N, Any_Type); 7569 return; 7570 end if; 7571 7572 -- Case of tagged type 7573 7574 else 7575 if Is_Concurrent_Type (T) then 7576 if No (Corresponding_Record_Type (Entity (Prefix (N)))) then 7577 7578 -- Previous error. Create a class-wide type for the 7579 -- synchronized type itself, with minimal semantic 7580 -- attributes, to catch other errors in some ACATS tests. 7581 7582 pragma Assert (Serious_Errors_Detected /= 0); 7583 Make_Class_Wide_Type (T); 7584 C := Class_Wide_Type (T); 7585 Set_First_Entity (C, First_Entity (T)); 7586 7587 else 7588 C := Class_Wide_Type 7589 (Corresponding_Record_Type (Entity (Prefix (N)))); 7590 end if; 7591 7592 else 7593 C := Class_Wide_Type (Entity (Prefix (N))); 7594 end if; 7595 7596 Set_Entity_With_Checks (N, C); 7597 Generate_Reference (C, N); 7598 Set_Etype (N, C); 7599 end if; 7600 7601 -- Base attribute, not allowed in Ada 83 7602 7603 elsif Attribute_Name (N) = Name_Base then 7604 Error_Msg_Name_1 := Name_Base; 7605 Check_SPARK_05_Restriction 7606 ("attribute% is only allowed as prefix of another attribute", N); 7607 7608 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 7609 Error_Msg_N 7610 ("(Ada 83) Base attribute not allowed in subtype mark", N); 7611 7612 else 7613 Find_Type (Prefix (N)); 7614 Typ := Entity (Prefix (N)); 7615 7616 if Ada_Version >= Ada_95 7617 and then not Is_Scalar_Type (Typ) 7618 and then not Is_Generic_Type (Typ) 7619 then 7620 Error_Msg_N 7621 ("prefix of Base attribute must be scalar type", 7622 Prefix (N)); 7623 7624 elsif Warn_On_Redundant_Constructs 7625 and then Base_Type (Typ) = Typ 7626 then 7627 Error_Msg_NE -- CODEFIX 7628 ("redundant attribute, & is its own base type?r?", N, Typ); 7629 end if; 7630 7631 T := Base_Type (Typ); 7632 7633 -- Rewrite attribute reference with type itself (see similar 7634 -- processing in Analyze_Attribute, case Base). Preserve prefix 7635 -- if present, for other legality checks. 7636 7637 if Nkind (Prefix (N)) = N_Expanded_Name then 7638 Rewrite (N, 7639 Make_Expanded_Name (Sloc (N), 7640 Chars => Chars (T), 7641 Prefix => New_Copy (Prefix (Prefix (N))), 7642 Selector_Name => New_Occurrence_Of (T, Sloc (N)))); 7643 7644 else 7645 Rewrite (N, New_Occurrence_Of (T, Sloc (N))); 7646 end if; 7647 7648 Set_Entity (N, T); 7649 Set_Etype (N, T); 7650 end if; 7651 7652 elsif Attribute_Name (N) = Name_Stub_Type then 7653 7654 -- This is handled in Analyze_Attribute 7655 7656 Analyze (N); 7657 7658 -- All other attributes are invalid in a subtype mark 7659 7660 else 7661 Error_Msg_N ("invalid attribute in subtype mark", N); 7662 end if; 7663 7664 else 7665 Analyze (N); 7666 7667 if Is_Entity_Name (N) then 7668 T_Name := Entity (N); 7669 else 7670 Error_Msg_N ("subtype mark required in this context", N); 7671 Set_Etype (N, Any_Type); 7672 return; 7673 end if; 7674 7675 if T_Name = Any_Id or else Etype (N) = Any_Type then 7676 7677 -- Undefined id. Make it into a valid type 7678 7679 Set_Entity (N, Any_Type); 7680 7681 elsif not Is_Type (T_Name) 7682 and then T_Name /= Standard_Void_Type 7683 then 7684 Error_Msg_Sloc := Sloc (T_Name); 7685 Error_Msg_N ("subtype mark required in this context", N); 7686 Error_Msg_NE ("\\found & declared#", N, T_Name); 7687 Set_Entity (N, Any_Type); 7688 7689 else 7690 -- If the type is an incomplete type created to handle 7691 -- anonymous access components of a record type, then the 7692 -- incomplete type is the visible entity and subsequent 7693 -- references will point to it. Mark the original full 7694 -- type as referenced, to prevent spurious warnings. 7695 7696 if Is_Incomplete_Type (T_Name) 7697 and then Present (Full_View (T_Name)) 7698 and then not Comes_From_Source (T_Name) 7699 then 7700 Set_Referenced (Full_View (T_Name)); 7701 end if; 7702 7703 T_Name := Get_Full_View (T_Name); 7704 7705 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through 7706 -- limited-with clauses 7707 7708 if From_Limited_With (T_Name) 7709 and then Ekind (T_Name) in Incomplete_Kind 7710 and then Present (Non_Limited_View (T_Name)) 7711 and then Is_Interface (Non_Limited_View (T_Name)) 7712 then 7713 T_Name := Non_Limited_View (T_Name); 7714 end if; 7715 7716 if In_Open_Scopes (T_Name) then 7717 if Ekind (Base_Type (T_Name)) = E_Task_Type then 7718 7719 -- In Ada 2005, a task name can be used in an access 7720 -- definition within its own body. It cannot be used 7721 -- in the discriminant part of the task declaration, 7722 -- nor anywhere else in the declaration because entries 7723 -- cannot have access parameters. 7724 7725 if Ada_Version >= Ada_2005 7726 and then Nkind (Parent (N)) = N_Access_Definition 7727 then 7728 Set_Entity (N, T_Name); 7729 Set_Etype (N, T_Name); 7730 7731 if Has_Completion (T_Name) then 7732 return; 7733 7734 else 7735 Error_Msg_N 7736 ("task type cannot be used as type mark " & 7737 "within its own declaration", N); 7738 end if; 7739 7740 else 7741 Error_Msg_N 7742 ("task type cannot be used as type mark " & 7743 "within its own spec or body", N); 7744 end if; 7745 7746 elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then 7747 7748 -- In Ada 2005, a protected name can be used in an access 7749 -- definition within its own body. 7750 7751 if Ada_Version >= Ada_2005 7752 and then Nkind (Parent (N)) = N_Access_Definition 7753 then 7754 Set_Entity (N, T_Name); 7755 Set_Etype (N, T_Name); 7756 return; 7757 7758 else 7759 Error_Msg_N 7760 ("protected type cannot be used as type mark " & 7761 "within its own spec or body", N); 7762 end if; 7763 7764 else 7765 Error_Msg_N ("type declaration cannot refer to itself", N); 7766 end if; 7767 7768 Set_Etype (N, Any_Type); 7769 Set_Entity (N, Any_Type); 7770 Set_Error_Posted (T_Name); 7771 return; 7772 end if; 7773 7774 Set_Entity (N, T_Name); 7775 Set_Etype (N, T_Name); 7776 end if; 7777 end if; 7778 7779 if Present (Etype (N)) and then Comes_From_Source (N) then 7780 if Is_Fixed_Point_Type (Etype (N)) then 7781 Check_Restriction (No_Fixed_Point, N); 7782 elsif Is_Floating_Point_Type (Etype (N)) then 7783 Check_Restriction (No_Floating_Point, N); 7784 end if; 7785 7786 -- A Ghost type must appear in a specific context 7787 7788 if Is_Ghost_Entity (Etype (N)) then 7789 Check_Ghost_Context (Etype (N), N); 7790 end if; 7791 end if; 7792 end Find_Type; 7793 7794 ------------------------------------ 7795 -- Has_Implicit_Character_Literal -- 7796 ------------------------------------ 7797 7798 function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is 7799 Id : Entity_Id; 7800 Found : Boolean := False; 7801 P : constant Entity_Id := Entity (Prefix (N)); 7802 Priv_Id : Entity_Id := Empty; 7803 7804 begin 7805 if Ekind (P) = E_Package and then not In_Open_Scopes (P) then 7806 Priv_Id := First_Private_Entity (P); 7807 end if; 7808 7809 if P = Standard_Standard then 7810 Change_Selected_Component_To_Expanded_Name (N); 7811 Rewrite (N, Selector_Name (N)); 7812 Analyze (N); 7813 Set_Etype (Original_Node (N), Standard_Character); 7814 return True; 7815 end if; 7816 7817 Id := First_Entity (P); 7818 while Present (Id) and then Id /= Priv_Id loop 7819 if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then 7820 7821 -- We replace the node with the literal itself, resolve as a 7822 -- character, and set the type correctly. 7823 7824 if not Found then 7825 Change_Selected_Component_To_Expanded_Name (N); 7826 Rewrite (N, Selector_Name (N)); 7827 Analyze (N); 7828 Set_Etype (N, Id); 7829 Set_Etype (Original_Node (N), Id); 7830 Found := True; 7831 7832 else 7833 -- More than one type derived from Character in given scope. 7834 -- Collect all possible interpretations. 7835 7836 Add_One_Interp (N, Id, Id); 7837 end if; 7838 end if; 7839 7840 Next_Entity (Id); 7841 end loop; 7842 7843 return Found; 7844 end Has_Implicit_Character_Literal; 7845 7846 ---------------------- 7847 -- Has_Private_With -- 7848 ---------------------- 7849 7850 function Has_Private_With (E : Entity_Id) return Boolean is 7851 Comp_Unit : constant Node_Id := Cunit (Current_Sem_Unit); 7852 Item : Node_Id; 7853 7854 begin 7855 Item := First (Context_Items (Comp_Unit)); 7856 while Present (Item) loop 7857 if Nkind (Item) = N_With_Clause 7858 and then Private_Present (Item) 7859 and then Entity (Name (Item)) = E 7860 then 7861 return True; 7862 end if; 7863 7864 Next (Item); 7865 end loop; 7866 7867 return False; 7868 end Has_Private_With; 7869 7870 --------------------------- 7871 -- Has_Implicit_Operator -- 7872 --------------------------- 7873 7874 function Has_Implicit_Operator (N : Node_Id) return Boolean is 7875 Op_Id : constant Name_Id := Chars (Selector_Name (N)); 7876 P : constant Entity_Id := Entity (Prefix (N)); 7877 Id : Entity_Id; 7878 Priv_Id : Entity_Id := Empty; 7879 7880 procedure Add_Implicit_Operator 7881 (T : Entity_Id; 7882 Op_Type : Entity_Id := Empty); 7883 -- Add implicit interpretation to node N, using the type for which a 7884 -- predefined operator exists. If the operator yields a boolean type, 7885 -- the Operand_Type is implicitly referenced by the operator, and a 7886 -- reference to it must be generated. 7887 7888 --------------------------- 7889 -- Add_Implicit_Operator -- 7890 --------------------------- 7891 7892 procedure Add_Implicit_Operator 7893 (T : Entity_Id; 7894 Op_Type : Entity_Id := Empty) 7895 is 7896 Predef_Op : Entity_Id; 7897 7898 begin 7899 Predef_Op := Current_Entity (Selector_Name (N)); 7900 while Present (Predef_Op) 7901 and then Scope (Predef_Op) /= Standard_Standard 7902 loop 7903 Predef_Op := Homonym (Predef_Op); 7904 end loop; 7905 7906 if Nkind (N) = N_Selected_Component then 7907 Change_Selected_Component_To_Expanded_Name (N); 7908 end if; 7909 7910 -- If the context is an unanalyzed function call, determine whether 7911 -- a binary or unary interpretation is required. 7912 7913 if Nkind (Parent (N)) = N_Indexed_Component then 7914 declare 7915 Is_Binary_Call : constant Boolean := 7916 Present 7917 (Next (First (Expressions (Parent (N))))); 7918 Is_Binary_Op : constant Boolean := 7919 First_Entity 7920 (Predef_Op) /= Last_Entity (Predef_Op); 7921 Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); 7922 7923 begin 7924 if Is_Binary_Call then 7925 if Is_Binary_Op then 7926 Add_One_Interp (N, Predef_Op, T); 7927 else 7928 Add_One_Interp (N, Predef_Op2, T); 7929 end if; 7930 7931 else 7932 if not Is_Binary_Op then 7933 Add_One_Interp (N, Predef_Op, T); 7934 else 7935 Add_One_Interp (N, Predef_Op2, T); 7936 end if; 7937 end if; 7938 end; 7939 7940 else 7941 Add_One_Interp (N, Predef_Op, T); 7942 7943 -- For operators with unary and binary interpretations, if 7944 -- context is not a call, add both 7945 7946 if Present (Homonym (Predef_Op)) then 7947 Add_One_Interp (N, Homonym (Predef_Op), T); 7948 end if; 7949 end if; 7950 7951 -- The node is a reference to a predefined operator, and 7952 -- an implicit reference to the type of its operands. 7953 7954 if Present (Op_Type) then 7955 Generate_Operator_Reference (N, Op_Type); 7956 else 7957 Generate_Operator_Reference (N, T); 7958 end if; 7959 end Add_Implicit_Operator; 7960 7961 -- Start of processing for Has_Implicit_Operator 7962 7963 begin 7964 if Ekind (P) = E_Package and then not In_Open_Scopes (P) then 7965 Priv_Id := First_Private_Entity (P); 7966 end if; 7967 7968 Id := First_Entity (P); 7969 7970 case Op_Id is 7971 7972 -- Boolean operators: an implicit declaration exists if the scope 7973 -- contains a declaration for a derived Boolean type, or for an 7974 -- array of Boolean type. 7975 7976 when Name_Op_And 7977 | Name_Op_Not 7978 | Name_Op_Or 7979 | Name_Op_Xor 7980 => 7981 while Id /= Priv_Id loop 7982 if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then 7983 Add_Implicit_Operator (Id); 7984 return True; 7985 end if; 7986 7987 Next_Entity (Id); 7988 end loop; 7989 7990 -- Equality: look for any non-limited type (result is Boolean) 7991 7992 when Name_Op_Eq 7993 | Name_Op_Ne 7994 => 7995 while Id /= Priv_Id loop 7996 if Is_Type (Id) 7997 and then not Is_Limited_Type (Id) 7998 and then Is_Base_Type (Id) 7999 then 8000 Add_Implicit_Operator (Standard_Boolean, Id); 8001 return True; 8002 end if; 8003 8004 Next_Entity (Id); 8005 end loop; 8006 8007 -- Comparison operators: scalar type, or array of scalar 8008 8009 when Name_Op_Ge 8010 | Name_Op_Gt 8011 | Name_Op_Le 8012 | Name_Op_Lt 8013 => 8014 while Id /= Priv_Id loop 8015 if (Is_Scalar_Type (Id) 8016 or else (Is_Array_Type (Id) 8017 and then Is_Scalar_Type (Component_Type (Id)))) 8018 and then Is_Base_Type (Id) 8019 then 8020 Add_Implicit_Operator (Standard_Boolean, Id); 8021 return True; 8022 end if; 8023 8024 Next_Entity (Id); 8025 end loop; 8026 8027 -- Arithmetic operators: any numeric type 8028 8029 when Name_Op_Abs 8030 | Name_Op_Add 8031 | Name_Op_Divide 8032 | Name_Op_Expon 8033 | Name_Op_Mod 8034 | Name_Op_Multiply 8035 | Name_Op_Rem 8036 | Name_Op_Subtract 8037 => 8038 while Id /= Priv_Id loop 8039 if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then 8040 Add_Implicit_Operator (Id); 8041 return True; 8042 end if; 8043 8044 Next_Entity (Id); 8045 end loop; 8046 8047 -- Concatenation: any one-dimensional array type 8048 8049 when Name_Op_Concat => 8050 while Id /= Priv_Id loop 8051 if Is_Array_Type (Id) 8052 and then Number_Dimensions (Id) = 1 8053 and then Is_Base_Type (Id) 8054 then 8055 Add_Implicit_Operator (Id); 8056 return True; 8057 end if; 8058 8059 Next_Entity (Id); 8060 end loop; 8061 8062 -- What is the others condition here? Should we be using a 8063 -- subtype of Name_Id that would restrict to operators ??? 8064 8065 when others => 8066 null; 8067 end case; 8068 8069 -- If we fall through, then we do not have an implicit operator 8070 8071 return False; 8072 end Has_Implicit_Operator; 8073 8074 ----------------------------------- 8075 -- Has_Loop_In_Inner_Open_Scopes -- 8076 ----------------------------------- 8077 8078 function Has_Loop_In_Inner_Open_Scopes (S : Entity_Id) return Boolean is 8079 begin 8080 -- Several scope stacks are maintained by Scope_Stack. The base of the 8081 -- currently active scope stack is denoted by the Is_Active_Stack_Base 8082 -- flag in the scope stack entry. Note that the scope stacks used to 8083 -- simply be delimited implicitly by the presence of Standard_Standard 8084 -- at their base, but there now are cases where this is not sufficient 8085 -- because Standard_Standard actually may appear in the middle of the 8086 -- active set of scopes. 8087 8088 for J in reverse 0 .. Scope_Stack.Last loop 8089 8090 -- S was reached without seing a loop scope first 8091 8092 if Scope_Stack.Table (J).Entity = S then 8093 return False; 8094 8095 -- S was not yet reached, so it contains at least one inner loop 8096 8097 elsif Ekind (Scope_Stack.Table (J).Entity) = E_Loop then 8098 return True; 8099 end if; 8100 8101 -- Check Is_Active_Stack_Base to tell us when to stop, as there are 8102 -- cases where Standard_Standard appears in the middle of the active 8103 -- set of scopes. This affects the declaration and overriding of 8104 -- private inherited operations in instantiations of generic child 8105 -- units. 8106 8107 pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base); 8108 end loop; 8109 8110 raise Program_Error; -- unreachable 8111 end Has_Loop_In_Inner_Open_Scopes; 8112 8113 -------------------- 8114 -- In_Open_Scopes -- 8115 -------------------- 8116 8117 function In_Open_Scopes (S : Entity_Id) return Boolean is 8118 begin 8119 -- Several scope stacks are maintained by Scope_Stack. The base of the 8120 -- currently active scope stack is denoted by the Is_Active_Stack_Base 8121 -- flag in the scope stack entry. Note that the scope stacks used to 8122 -- simply be delimited implicitly by the presence of Standard_Standard 8123 -- at their base, but there now are cases where this is not sufficient 8124 -- because Standard_Standard actually may appear in the middle of the 8125 -- active set of scopes. 8126 8127 for J in reverse 0 .. Scope_Stack.Last loop 8128 if Scope_Stack.Table (J).Entity = S then 8129 return True; 8130 end if; 8131 8132 -- Check Is_Active_Stack_Base to tell us when to stop, as there are 8133 -- cases where Standard_Standard appears in the middle of the active 8134 -- set of scopes. This affects the declaration and overriding of 8135 -- private inherited operations in instantiations of generic child 8136 -- units. 8137 8138 exit when Scope_Stack.Table (J).Is_Active_Stack_Base; 8139 end loop; 8140 8141 return False; 8142 end In_Open_Scopes; 8143 8144 ----------------------------- 8145 -- Inherit_Renamed_Profile -- 8146 ----------------------------- 8147 8148 procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is 8149 New_F : Entity_Id; 8150 Old_F : Entity_Id; 8151 Old_T : Entity_Id; 8152 New_T : Entity_Id; 8153 8154 begin 8155 if Ekind (Old_S) = E_Operator then 8156 New_F := First_Formal (New_S); 8157 8158 while Present (New_F) loop 8159 Set_Etype (New_F, Base_Type (Etype (New_F))); 8160 Next_Formal (New_F); 8161 end loop; 8162 8163 Set_Etype (New_S, Base_Type (Etype (New_S))); 8164 8165 else 8166 New_F := First_Formal (New_S); 8167 Old_F := First_Formal (Old_S); 8168 8169 while Present (New_F) loop 8170 New_T := Etype (New_F); 8171 Old_T := Etype (Old_F); 8172 8173 -- If the new type is a renaming of the old one, as is the case 8174 -- for actuals in instances, retain its name, to simplify later 8175 -- disambiguation. 8176 8177 if Nkind (Parent (New_T)) = N_Subtype_Declaration 8178 and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) 8179 and then Entity (Subtype_Indication (Parent (New_T))) = Old_T 8180 then 8181 null; 8182 else 8183 Set_Etype (New_F, Old_T); 8184 end if; 8185 8186 Next_Formal (New_F); 8187 Next_Formal (Old_F); 8188 end loop; 8189 8190 pragma Assert (No (Old_F)); 8191 8192 if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then 8193 Set_Etype (New_S, Etype (Old_S)); 8194 end if; 8195 end if; 8196 end Inherit_Renamed_Profile; 8197 8198 ---------------- 8199 -- Initialize -- 8200 ---------------- 8201 8202 procedure Initialize is 8203 begin 8204 Urefs.Init; 8205 end Initialize; 8206 8207 ------------------------- 8208 -- Install_Use_Clauses -- 8209 ------------------------- 8210 8211 procedure Install_Use_Clauses 8212 (Clause : Node_Id; 8213 Force_Installation : Boolean := False) 8214 is 8215 U : Node_Id; 8216 8217 begin 8218 U := Clause; 8219 while Present (U) loop 8220 8221 -- Case of USE package 8222 8223 if Nkind (U) = N_Use_Package_Clause then 8224 Use_One_Package (U, Name (U), True); 8225 8226 -- Case of USE TYPE 8227 8228 else 8229 Use_One_Type (Subtype_Mark (U), Force => Force_Installation); 8230 8231 end if; 8232 8233 Next_Use_Clause (U); 8234 end loop; 8235 end Install_Use_Clauses; 8236 8237 ------------------------------------- 8238 -- Is_Appropriate_For_Entry_Prefix -- 8239 ------------------------------------- 8240 8241 function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is 8242 P_Type : Entity_Id := T; 8243 8244 begin 8245 if Is_Access_Type (P_Type) then 8246 P_Type := Designated_Type (P_Type); 8247 end if; 8248 8249 return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); 8250 end Is_Appropriate_For_Entry_Prefix; 8251 8252 ------------------------------- 8253 -- Is_Appropriate_For_Record -- 8254 ------------------------------- 8255 8256 function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is 8257 8258 function Has_Components (T1 : Entity_Id) return Boolean; 8259 -- Determine if given type has components (i.e. is either a record 8260 -- type or a type that has discriminants). 8261 8262 -------------------- 8263 -- Has_Components -- 8264 -------------------- 8265 8266 function Has_Components (T1 : Entity_Id) return Boolean is 8267 begin 8268 return Is_Record_Type (T1) 8269 or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) 8270 or else (Is_Task_Type (T1) and then Has_Discriminants (T1)) 8271 or else (Is_Incomplete_Type (T1) 8272 and then From_Limited_With (T1) 8273 and then Present (Non_Limited_View (T1)) 8274 and then Is_Record_Type 8275 (Get_Full_View (Non_Limited_View (T1)))); 8276 end Has_Components; 8277 8278 -- Start of processing for Is_Appropriate_For_Record 8279 8280 begin 8281 return 8282 Present (T) 8283 and then (Has_Components (T) 8284 or else (Is_Access_Type (T) 8285 and then Has_Components (Designated_Type (T)))); 8286 end Is_Appropriate_For_Record; 8287 8288 ---------------------- 8289 -- Mark_Use_Clauses -- 8290 ---------------------- 8291 8292 procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is 8293 procedure Mark_Parameters (Call : Entity_Id); 8294 -- Perform use_type_clause marking for all parameters in a subprogram 8295 -- or operator call. 8296 8297 procedure Mark_Use_Package (Pak : Entity_Id); 8298 -- Move up the Prev_Use_Clause chain for packages denoted by Pak - 8299 -- marking each clause in the chain as effective in the process. 8300 8301 procedure Mark_Use_Type (E : Entity_Id); 8302 -- Similar to Do_Use_Package_Marking except we move up the 8303 -- Prev_Use_Clause chain for the type denoted by E. 8304 8305 --------------------- 8306 -- Mark_Parameters -- 8307 --------------------- 8308 8309 procedure Mark_Parameters (Call : Entity_Id) is 8310 Curr : Node_Id; 8311 8312 begin 8313 -- Move through all of the formals 8314 8315 Curr := First_Formal (Call); 8316 while Present (Curr) loop 8317 Mark_Use_Type (Curr); 8318 8319 Curr := Next_Formal (Curr); 8320 end loop; 8321 8322 -- Handle the return type 8323 8324 Mark_Use_Type (Call); 8325 end Mark_Parameters; 8326 8327 ---------------------- 8328 -- Mark_Use_Package -- 8329 ---------------------- 8330 8331 procedure Mark_Use_Package (Pak : Entity_Id) is 8332 Curr : Node_Id; 8333 8334 begin 8335 -- Ignore cases where the scope of the type is not a package (e.g. 8336 -- Standard_Standard). 8337 8338 if Ekind (Pak) /= E_Package then 8339 return; 8340 end if; 8341 8342 Curr := Current_Use_Clause (Pak); 8343 while Present (Curr) 8344 and then not Is_Effective_Use_Clause (Curr) 8345 loop 8346 -- We need to mark the previous use clauses as effective, but 8347 -- each use clause may in turn render other use_package_clauses 8348 -- effective. Additionally, it is possible to have a parent 8349 -- package renamed as a child of itself so we must check the 8350 -- prefix entity is not the same as the package we are marking. 8351 8352 if Nkind (Name (Curr)) /= N_Identifier 8353 and then Present (Prefix (Name (Curr))) 8354 and then Entity (Prefix (Name (Curr))) /= Pak 8355 then 8356 Mark_Use_Package (Entity (Prefix (Name (Curr)))); 8357 8358 -- It is also possible to have a child package without a prefix 8359 -- that relies on a previous use_package_clause. 8360 8361 elsif Nkind (Name (Curr)) = N_Identifier 8362 and then Is_Child_Unit (Entity (Name (Curr))) 8363 then 8364 Mark_Use_Package (Scope (Entity (Name (Curr)))); 8365 end if; 8366 8367 -- Mark the use_package_clause as effective and move up the chain 8368 8369 Set_Is_Effective_Use_Clause (Curr); 8370 8371 Curr := Prev_Use_Clause (Curr); 8372 end loop; 8373 end Mark_Use_Package; 8374 8375 ------------------- 8376 -- Mark_Use_Type -- 8377 ------------------- 8378 8379 procedure Mark_Use_Type (E : Entity_Id) is 8380 Curr : Node_Id; 8381 Base : Entity_Id; 8382 8383 begin 8384 -- Ignore void types and unresolved string literals and primitives 8385 8386 if Nkind (E) = N_String_Literal 8387 or else Nkind (Etype (E)) not in N_Entity 8388 or else not Is_Type (Etype (E)) 8389 then 8390 return; 8391 end if; 8392 8393 -- Primitives with class-wide operands might additionally render 8394 -- their base type's use_clauses effective - so do a recursive check 8395 -- here. 8396 8397 Base := Base_Type (Etype (E)); 8398 8399 if Ekind (Base) = E_Class_Wide_Type then 8400 Mark_Use_Type (Base); 8401 end if; 8402 8403 -- The package containing the type or operator function being used 8404 -- may be in use as well, so mark any use_package_clauses for it as 8405 -- effective. There are also additional sanity checks performed here 8406 -- for ignoring previous errors. 8407 8408 Mark_Use_Package (Scope (Base)); 8409 8410 if Nkind (E) in N_Op 8411 and then Present (Entity (E)) 8412 and then Present (Scope (Entity (E))) 8413 then 8414 Mark_Use_Package (Scope (Entity (E))); 8415 end if; 8416 8417 Curr := Current_Use_Clause (Base); 8418 while Present (Curr) 8419 and then not Is_Effective_Use_Clause (Curr) 8420 loop 8421 -- Current use_type_clause may render other use_package_clauses 8422 -- effective. 8423 8424 if Nkind (Subtype_Mark (Curr)) /= N_Identifier 8425 and then Present (Prefix (Subtype_Mark (Curr))) 8426 then 8427 Mark_Use_Package (Entity (Prefix (Subtype_Mark (Curr)))); 8428 end if; 8429 8430 -- Mark the use_type_clause as effective and move up the chain 8431 8432 Set_Is_Effective_Use_Clause (Curr); 8433 8434 Curr := Prev_Use_Clause (Curr); 8435 end loop; 8436 end Mark_Use_Type; 8437 8438 -- Start of processing for Mark_Use_Clauses 8439 8440 begin 8441 -- Use clauses in and of themselves do not count as a "use" of a 8442 -- package. 8443 8444 if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then 8445 return; 8446 end if; 8447 8448 -- Handle entities 8449 8450 if Nkind (Id) in N_Entity then 8451 8452 -- Mark the entity's package 8453 8454 if Is_Potentially_Use_Visible (Id) then 8455 Mark_Use_Package (Scope (Id)); 8456 end if; 8457 8458 -- Mark enumeration literals 8459 8460 if Ekind (Id) = E_Enumeration_Literal then 8461 Mark_Use_Type (Id); 8462 8463 -- Mark primitives 8464 8465 elsif (Ekind (Id) in Overloadable_Kind 8466 or else Ekind_In (Id, E_Generic_Function, 8467 E_Generic_Procedure)) 8468 and then (Is_Potentially_Use_Visible (Id) 8469 or else Is_Intrinsic_Subprogram (Id) 8470 or else (Ekind_In (Id, E_Function, E_Procedure) 8471 and then Is_Generic_Actual_Subprogram (Id))) 8472 then 8473 Mark_Parameters (Id); 8474 end if; 8475 8476 -- Handle nodes 8477 8478 else 8479 -- Mark operators 8480 8481 if Nkind (Id) in N_Op then 8482 8483 -- At this point the left operand may not be resolved if we are 8484 -- encountering multiple operators next to eachother in an 8485 -- expression. 8486 8487 if Nkind (Id) in N_Binary_Op 8488 and then not (Nkind (Left_Opnd (Id)) in N_Op) 8489 then 8490 Mark_Use_Type (Left_Opnd (Id)); 8491 end if; 8492 8493 Mark_Use_Type (Right_Opnd (Id)); 8494 Mark_Use_Type (Id); 8495 8496 -- Mark entity identifiers 8497 8498 elsif Nkind (Id) in N_Has_Entity 8499 and then (Is_Potentially_Use_Visible (Entity (Id)) 8500 or else (Is_Generic_Instance (Entity (Id)) 8501 and then Is_Immediately_Visible (Entity (Id)))) 8502 then 8503 -- Ignore fully qualified names as they do not count as a "use" of 8504 -- a package. 8505 8506 if Nkind_In (Id, N_Identifier, N_Operator_Symbol) 8507 or else (Present (Prefix (Id)) 8508 and then Scope (Entity (Id)) /= Entity (Prefix (Id))) 8509 then 8510 Mark_Use_Clauses (Entity (Id)); 8511 end if; 8512 end if; 8513 end if; 8514 end Mark_Use_Clauses; 8515 8516 -------------------------------- 8517 -- Most_Descendant_Use_Clause -- 8518 -------------------------------- 8519 8520 function Most_Descendant_Use_Clause 8521 (Clause1 : Entity_Id; 8522 Clause2 : Entity_Id) return Entity_Id 8523 is 8524 Scope1, Scope2 : Entity_Id; 8525 8526 begin 8527 if Clause1 = Clause2 then 8528 return Clause1; 8529 end if; 8530 8531 -- We determine which one is the most descendant by the scope distance 8532 -- to the ultimate parent unit. 8533 8534 Scope1 := Entity_Of_Unit (Unit (Parent (Clause1))); 8535 Scope2 := Entity_Of_Unit (Unit (Parent (Clause2))); 8536 while Scope1 /= Standard_Standard 8537 and then Scope2 /= Standard_Standard 8538 loop 8539 Scope1 := Scope (Scope1); 8540 Scope2 := Scope (Scope2); 8541 8542 if not Present (Scope1) then 8543 return Clause1; 8544 elsif not Present (Scope2) then 8545 return Clause2; 8546 end if; 8547 end loop; 8548 8549 if Scope1 = Standard_Standard then 8550 return Clause1; 8551 end if; 8552 8553 return Clause2; 8554 end Most_Descendant_Use_Clause; 8555 8556 --------------- 8557 -- Pop_Scope -- 8558 --------------- 8559 8560 procedure Pop_Scope is 8561 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 8562 S : constant Entity_Id := SST.Entity; 8563 8564 begin 8565 if Debug_Flag_E then 8566 Write_Info; 8567 end if; 8568 8569 -- Set Default_Storage_Pool field of the library unit if necessary 8570 8571 if Ekind_In (S, E_Package, E_Generic_Package) 8572 and then 8573 Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit 8574 then 8575 declare 8576 Aux : constant Node_Id := 8577 Aux_Decls_Node (Parent (Unit_Declaration_Node (S))); 8578 begin 8579 if No (Default_Storage_Pool (Aux)) then 8580 Set_Default_Storage_Pool (Aux, Default_Pool); 8581 end if; 8582 end; 8583 end if; 8584 8585 Scope_Suppress := SST.Save_Scope_Suppress; 8586 Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; 8587 Check_Policy_List := SST.Save_Check_Policy_List; 8588 Default_Pool := SST.Save_Default_Storage_Pool; 8589 No_Tagged_Streams := SST.Save_No_Tagged_Streams; 8590 SPARK_Mode := SST.Save_SPARK_Mode; 8591 SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma; 8592 Default_SSO := SST.Save_Default_SSO; 8593 Uneval_Old := SST.Save_Uneval_Old; 8594 8595 if Debug_Flag_W then 8596 Write_Str ("<-- exiting scope: "); 8597 Write_Name (Chars (Current_Scope)); 8598 Write_Str (", Depth="); 8599 Write_Int (Int (Scope_Stack.Last)); 8600 Write_Eol; 8601 end if; 8602 8603 End_Use_Clauses (SST.First_Use_Clause); 8604 8605 -- If the actions to be wrapped are still there they will get lost 8606 -- causing incomplete code to be generated. It is better to abort in 8607 -- this case (and we do the abort even with assertions off since the 8608 -- penalty is incorrect code generation). 8609 8610 if SST.Actions_To_Be_Wrapped /= Scope_Actions'(others => No_List) then 8611 raise Program_Error; 8612 end if; 8613 8614 -- Free last subprogram name if allocated, and pop scope 8615 8616 Free (SST.Last_Subprogram_Name); 8617 Scope_Stack.Decrement_Last; 8618 end Pop_Scope; 8619 8620 ---------------- 8621 -- Push_Scope -- 8622 ---------------- 8623 8624 procedure Push_Scope (S : Entity_Id) is 8625 E : constant Entity_Id := Scope (S); 8626 8627 begin 8628 if Ekind (S) = E_Void then 8629 null; 8630 8631 -- Set scope depth if not a non-concurrent type, and we have not yet set 8632 -- the scope depth. This means that we have the first occurrence of the 8633 -- scope, and this is where the depth is set. 8634 8635 elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) 8636 and then not Scope_Depth_Set (S) 8637 then 8638 if S = Standard_Standard then 8639 Set_Scope_Depth_Value (S, Uint_0); 8640 8641 elsif Is_Child_Unit (S) then 8642 Set_Scope_Depth_Value (S, Uint_1); 8643 8644 elsif not Is_Record_Type (Current_Scope) then 8645 if Ekind (S) = E_Loop then 8646 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); 8647 else 8648 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); 8649 end if; 8650 end if; 8651 end if; 8652 8653 Scope_Stack.Increment_Last; 8654 8655 declare 8656 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 8657 8658 begin 8659 SST.Entity := S; 8660 SST.Save_Scope_Suppress := Scope_Suppress; 8661 SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; 8662 SST.Save_Check_Policy_List := Check_Policy_List; 8663 SST.Save_Default_Storage_Pool := Default_Pool; 8664 SST.Save_No_Tagged_Streams := No_Tagged_Streams; 8665 SST.Save_SPARK_Mode := SPARK_Mode; 8666 SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma; 8667 SST.Save_Default_SSO := Default_SSO; 8668 SST.Save_Uneval_Old := Uneval_Old; 8669 8670 -- Each new scope pushed onto the scope stack inherits the component 8671 -- alignment of the previous scope. This emulates the "visibility" 8672 -- semantics of pragma Component_Alignment. 8673 8674 if Scope_Stack.Last > Scope_Stack.First then 8675 SST.Component_Alignment_Default := 8676 Scope_Stack.Table 8677 (Scope_Stack.Last - 1). Component_Alignment_Default; 8678 8679 -- Otherwise, this is the first scope being pushed on the scope 8680 -- stack. Inherit the component alignment from the configuration 8681 -- form of pragma Component_Alignment (if any). 8682 8683 else 8684 SST.Component_Alignment_Default := 8685 Configuration_Component_Alignment; 8686 end if; 8687 8688 SST.Last_Subprogram_Name := null; 8689 SST.Is_Transient := False; 8690 SST.Node_To_Be_Wrapped := Empty; 8691 SST.Pending_Freeze_Actions := No_List; 8692 SST.Actions_To_Be_Wrapped := (others => No_List); 8693 SST.First_Use_Clause := Empty; 8694 SST.Is_Active_Stack_Base := False; 8695 SST.Previous_Visibility := False; 8696 SST.Locked_Shared_Objects := No_Elist; 8697 end; 8698 8699 if Debug_Flag_W then 8700 Write_Str ("--> new scope: "); 8701 Write_Name (Chars (Current_Scope)); 8702 Write_Str (", Id="); 8703 Write_Int (Int (Current_Scope)); 8704 Write_Str (", Depth="); 8705 Write_Int (Int (Scope_Stack.Last)); 8706 Write_Eol; 8707 end if; 8708 8709 -- Deal with copying flags from the previous scope to this one. This is 8710 -- not necessary if either scope is standard, or if the new scope is a 8711 -- child unit. 8712 8713 if S /= Standard_Standard 8714 and then Scope (S) /= Standard_Standard 8715 and then not Is_Child_Unit (S) 8716 then 8717 if Nkind (E) not in N_Entity then 8718 return; 8719 end if; 8720 8721 -- Copy categorization flags from Scope (S) to S, this is not done 8722 -- when Scope (S) is Standard_Standard since propagation is from 8723 -- library unit entity inwards. Copy other relevant attributes as 8724 -- well (Discard_Names in particular). 8725 8726 -- We only propagate inwards for library level entities, 8727 -- inner level subprograms do not inherit the categorization. 8728 8729 if Is_Library_Level_Entity (S) then 8730 Set_Is_Preelaborated (S, Is_Preelaborated (E)); 8731 Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); 8732 Set_Discard_Names (S, Discard_Names (E)); 8733 Set_Suppress_Value_Tracking_On_Call 8734 (S, Suppress_Value_Tracking_On_Call (E)); 8735 Set_Categorization_From_Scope (E => S, Scop => E); 8736 end if; 8737 end if; 8738 8739 if Is_Child_Unit (S) 8740 and then Present (E) 8741 and then Ekind_In (E, E_Package, E_Generic_Package) 8742 and then 8743 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 8744 then 8745 declare 8746 Aux : constant Node_Id := 8747 Aux_Decls_Node (Parent (Unit_Declaration_Node (E))); 8748 begin 8749 if Present (Default_Storage_Pool (Aux)) then 8750 Default_Pool := Default_Storage_Pool (Aux); 8751 end if; 8752 end; 8753 end if; 8754 end Push_Scope; 8755 8756 --------------------- 8757 -- Premature_Usage -- 8758 --------------------- 8759 8760 procedure Premature_Usage (N : Node_Id) is 8761 Kind : constant Node_Kind := Nkind (Parent (Entity (N))); 8762 E : Entity_Id := Entity (N); 8763 8764 begin 8765 -- Within an instance, the analysis of the actual for a formal object 8766 -- does not see the name of the object itself. This is significant only 8767 -- if the object is an aggregate, where its analysis does not do any 8768 -- name resolution on component associations. (see 4717-008). In such a 8769 -- case, look for the visible homonym on the chain. 8770 8771 if In_Instance and then Present (Homonym (E)) then 8772 E := Homonym (E); 8773 while Present (E) and then not In_Open_Scopes (Scope (E)) loop 8774 E := Homonym (E); 8775 end loop; 8776 8777 if Present (E) then 8778 Set_Entity (N, E); 8779 Set_Etype (N, Etype (E)); 8780 return; 8781 end if; 8782 end if; 8783 8784 if Kind = N_Component_Declaration then 8785 Error_Msg_N 8786 ("component&! cannot be used before end of record declaration", N); 8787 8788 elsif Kind = N_Parameter_Specification then 8789 Error_Msg_N 8790 ("formal parameter&! cannot be used before end of specification", 8791 N); 8792 8793 elsif Kind = N_Discriminant_Specification then 8794 Error_Msg_N 8795 ("discriminant&! cannot be used before end of discriminant part", 8796 N); 8797 8798 elsif Kind = N_Procedure_Specification 8799 or else Kind = N_Function_Specification 8800 then 8801 Error_Msg_N 8802 ("subprogram&! cannot be used before end of its declaration", 8803 N); 8804 8805 elsif Kind = N_Full_Type_Declaration then 8806 Error_Msg_N 8807 ("type& cannot be used before end of its declaration!", N); 8808 8809 else 8810 Error_Msg_N 8811 ("object& cannot be used before end of its declaration!", N); 8812 8813 -- If the premature reference appears as the expression in its own 8814 -- declaration, rewrite it to prevent compiler loops in subsequent 8815 -- uses of this mangled declaration in address clauses. 8816 8817 if Nkind (Parent (N)) = N_Object_Declaration then 8818 Set_Entity (N, Any_Id); 8819 end if; 8820 end if; 8821 end Premature_Usage; 8822 8823 ------------------------ 8824 -- Present_System_Aux -- 8825 ------------------------ 8826 8827 function Present_System_Aux (N : Node_Id := Empty) return Boolean is 8828 Loc : Source_Ptr; 8829 Aux_Name : Unit_Name_Type; 8830 Unum : Unit_Number_Type; 8831 Withn : Node_Id; 8832 With_Sys : Node_Id; 8833 The_Unit : Node_Id; 8834 8835 function Find_System (C_Unit : Node_Id) return Entity_Id; 8836 -- Scan context clause of compilation unit to find with_clause 8837 -- for System. 8838 8839 ----------------- 8840 -- Find_System -- 8841 ----------------- 8842 8843 function Find_System (C_Unit : Node_Id) return Entity_Id is 8844 With_Clause : Node_Id; 8845 8846 begin 8847 With_Clause := First (Context_Items (C_Unit)); 8848 while Present (With_Clause) loop 8849 if (Nkind (With_Clause) = N_With_Clause 8850 and then Chars (Name (With_Clause)) = Name_System) 8851 and then Comes_From_Source (With_Clause) 8852 then 8853 return With_Clause; 8854 end if; 8855 8856 Next (With_Clause); 8857 end loop; 8858 8859 return Empty; 8860 end Find_System; 8861 8862 -- Start of processing for Present_System_Aux 8863 8864 begin 8865 -- The child unit may have been loaded and analyzed already 8866 8867 if Present (System_Aux_Id) then 8868 return True; 8869 8870 -- If no previous pragma for System.Aux, nothing to load 8871 8872 elsif No (System_Extend_Unit) then 8873 return False; 8874 8875 -- Use the unit name given in the pragma to retrieve the unit. 8876 -- Verify that System itself appears in the context clause of the 8877 -- current compilation. If System is not present, an error will 8878 -- have been reported already. 8879 8880 else 8881 With_Sys := Find_System (Cunit (Current_Sem_Unit)); 8882 8883 The_Unit := Unit (Cunit (Current_Sem_Unit)); 8884 8885 if No (With_Sys) 8886 and then 8887 (Nkind (The_Unit) = N_Package_Body 8888 or else (Nkind (The_Unit) = N_Subprogram_Body 8889 and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) 8890 then 8891 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); 8892 end if; 8893 8894 if No (With_Sys) and then Present (N) then 8895 8896 -- If we are compiling a subunit, we need to examine its 8897 -- context as well (Current_Sem_Unit is the parent unit); 8898 8899 The_Unit := Parent (N); 8900 while Nkind (The_Unit) /= N_Compilation_Unit loop 8901 The_Unit := Parent (The_Unit); 8902 end loop; 8903 8904 if Nkind (Unit (The_Unit)) = N_Subunit then 8905 With_Sys := Find_System (The_Unit); 8906 end if; 8907 end if; 8908 8909 if No (With_Sys) then 8910 return False; 8911 end if; 8912 8913 Loc := Sloc (With_Sys); 8914 Get_Name_String (Chars (Expression (System_Extend_Unit))); 8915 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); 8916 Name_Buffer (1 .. 7) := "system."; 8917 Name_Buffer (Name_Len + 8) := '%'; 8918 Name_Buffer (Name_Len + 9) := 's'; 8919 Name_Len := Name_Len + 9; 8920 Aux_Name := Name_Find; 8921 8922 Unum := 8923 Load_Unit 8924 (Load_Name => Aux_Name, 8925 Required => False, 8926 Subunit => False, 8927 Error_Node => With_Sys); 8928 8929 if Unum /= No_Unit then 8930 Semantics (Cunit (Unum)); 8931 System_Aux_Id := 8932 Defining_Entity (Specification (Unit (Cunit (Unum)))); 8933 8934 Withn := 8935 Make_With_Clause (Loc, 8936 Name => 8937 Make_Expanded_Name (Loc, 8938 Chars => Chars (System_Aux_Id), 8939 Prefix => 8940 New_Occurrence_Of (Scope (System_Aux_Id), Loc), 8941 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc))); 8942 8943 Set_Entity (Name (Withn), System_Aux_Id); 8944 8945 Set_Corresponding_Spec (Withn, System_Aux_Id); 8946 Set_First_Name (Withn); 8947 Set_Implicit_With (Withn); 8948 Set_Library_Unit (Withn, Cunit (Unum)); 8949 8950 Insert_After (With_Sys, Withn); 8951 Mark_Rewrite_Insertion (Withn); 8952 Set_Context_Installed (Withn); 8953 8954 return True; 8955 8956 -- Here if unit load failed 8957 8958 else 8959 Error_Msg_Name_1 := Name_System; 8960 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit)); 8961 Error_Msg_N 8962 ("extension package `%.%` does not exist", 8963 Opt.System_Extend_Unit); 8964 return False; 8965 end if; 8966 end if; 8967 end Present_System_Aux; 8968 8969 ------------------------- 8970 -- Restore_Scope_Stack -- 8971 ------------------------- 8972 8973 procedure Restore_Scope_Stack 8974 (List : Elist_Id; 8975 Handle_Use : Boolean := True) 8976 is 8977 SS_Last : constant Int := Scope_Stack.Last; 8978 Elmt : Elmt_Id; 8979 8980 begin 8981 -- Restore visibility of previous scope stack, if any, using the list 8982 -- we saved (we use Remove, since this list will not be used again). 8983 8984 loop 8985 Elmt := Last_Elmt (List); 8986 exit when Elmt = No_Elmt; 8987 Set_Is_Immediately_Visible (Node (Elmt)); 8988 Remove_Last_Elmt (List); 8989 end loop; 8990 8991 -- Restore use clauses 8992 8993 if SS_Last >= Scope_Stack.First 8994 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 8995 and then Handle_Use 8996 then 8997 Install_Use_Clauses 8998 (Scope_Stack.Table (SS_Last).First_Use_Clause, 8999 Force_Installation => True); 9000 end if; 9001 end Restore_Scope_Stack; 9002 9003 ---------------------- 9004 -- Save_Scope_Stack -- 9005 ---------------------- 9006 9007 -- Save_Scope_Stack/Restore_Scope_Stack were originally designed to avoid 9008 -- consuming any memory. That is, Save_Scope_Stack took care of removing 9009 -- from immediate visibility entities and Restore_Scope_Stack took care 9010 -- of restoring their visibility analyzing the context of each entity. The 9011 -- problem of such approach is that it was fragile and caused unexpected 9012 -- visibility problems, and indeed one test was found where there was a 9013 -- real problem. 9014 9015 -- Furthermore, the following experiment was carried out: 9016 9017 -- - Save_Scope_Stack was modified to store in an Elist1 all those 9018 -- entities whose attribute Is_Immediately_Visible is modified 9019 -- from True to False. 9020 9021 -- - Restore_Scope_Stack was modified to store in another Elist2 9022 -- all the entities whose attribute Is_Immediately_Visible is 9023 -- modified from False to True. 9024 9025 -- - Extra code was added to verify that all the elements of Elist1 9026 -- are found in Elist2 9027 9028 -- This test shows that there may be more occurrences of this problem which 9029 -- have not yet been detected. As a result, we replaced that approach by 9030 -- the current one in which Save_Scope_Stack returns the list of entities 9031 -- whose visibility is changed, and that list is passed to Restore_Scope_ 9032 -- Stack to undo that change. This approach is simpler and safer, although 9033 -- it consumes more memory. 9034 9035 function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is 9036 Result : constant Elist_Id := New_Elmt_List; 9037 E : Entity_Id; 9038 S : Entity_Id; 9039 SS_Last : constant Int := Scope_Stack.Last; 9040 9041 procedure Remove_From_Visibility (E : Entity_Id); 9042 -- If E is immediately visible then append it to the result and remove 9043 -- it temporarily from visibility. 9044 9045 ---------------------------- 9046 -- Remove_From_Visibility -- 9047 ---------------------------- 9048 9049 procedure Remove_From_Visibility (E : Entity_Id) is 9050 begin 9051 if Is_Immediately_Visible (E) then 9052 Append_Elmt (E, Result); 9053 Set_Is_Immediately_Visible (E, False); 9054 end if; 9055 end Remove_From_Visibility; 9056 9057 -- Start of processing for Save_Scope_Stack 9058 9059 begin 9060 if SS_Last >= Scope_Stack.First 9061 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 9062 then 9063 if Handle_Use then 9064 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); 9065 end if; 9066 9067 -- If the call is from within a compilation unit, as when called from 9068 -- Rtsfind, make current entries in scope stack invisible while we 9069 -- analyze the new unit. 9070 9071 for J in reverse 0 .. SS_Last loop 9072 exit when Scope_Stack.Table (J).Entity = Standard_Standard 9073 or else No (Scope_Stack.Table (J).Entity); 9074 9075 S := Scope_Stack.Table (J).Entity; 9076 9077 Remove_From_Visibility (S); 9078 9079 E := First_Entity (S); 9080 while Present (E) loop 9081 Remove_From_Visibility (E); 9082 Next_Entity (E); 9083 end loop; 9084 end loop; 9085 9086 end if; 9087 9088 return Result; 9089 end Save_Scope_Stack; 9090 9091 ------------- 9092 -- Set_Use -- 9093 ------------- 9094 9095 procedure Set_Use (L : List_Id) is 9096 Decl : Node_Id; 9097 9098 begin 9099 if Present (L) then 9100 Decl := First (L); 9101 while Present (Decl) loop 9102 if Nkind (Decl) = N_Use_Package_Clause then 9103 Chain_Use_Clause (Decl); 9104 Use_One_Package (Decl, Name (Decl)); 9105 9106 elsif Nkind (Decl) = N_Use_Type_Clause then 9107 Chain_Use_Clause (Decl); 9108 Use_One_Type (Subtype_Mark (Decl)); 9109 9110 end if; 9111 9112 Next (Decl); 9113 end loop; 9114 end if; 9115 end Set_Use; 9116 9117 ----------------------------- 9118 -- Update_Use_Clause_Chain -- 9119 ----------------------------- 9120 9121 procedure Update_Use_Clause_Chain is 9122 9123 procedure Update_Chain_In_Scope (Level : Int); 9124 -- Iterate through one level in the scope stack verifying each use-type 9125 -- clause within said level is used then reset the Current_Use_Clause 9126 -- to a redundant use clause outside of the current ending scope if such 9127 -- a clause exists. 9128 9129 --------------------------- 9130 -- Update_Chain_In_Scope -- 9131 --------------------------- 9132 9133 procedure Update_Chain_In_Scope (Level : Int) is 9134 Curr : Node_Id; 9135 N : Node_Id; 9136 9137 begin 9138 -- Loop through all use clauses within the scope dictated by Level 9139 9140 Curr := Scope_Stack.Table (Level).First_Use_Clause; 9141 while Present (Curr) loop 9142 9143 -- Retrieve the subtype mark or name within the current current 9144 -- use clause. 9145 9146 if Nkind (Curr) = N_Use_Type_Clause then 9147 N := Subtype_Mark (Curr); 9148 else 9149 N := Name (Curr); 9150 end if; 9151 9152 -- If warnings for unreferenced entities are enabled and the 9153 -- current use clause has not been marked effective. 9154 9155 if Check_Unreferenced 9156 and then Comes_From_Source (Curr) 9157 and then not Is_Effective_Use_Clause (Curr) 9158 and then not In_Instance 9159 and then not In_Inlined_Body 9160 then 9161 -- We are dealing with a potentially unused use_package_clause 9162 9163 if Nkind (Curr) = N_Use_Package_Clause then 9164 9165 -- Renamings and formal subprograms may cause the associated 9166 -- node to be marked as effective instead of the original. 9167 9168 if not (Present (Associated_Node (N)) 9169 and then Present 9170 (Current_Use_Clause 9171 (Associated_Node (N))) 9172 and then Is_Effective_Use_Clause 9173 (Current_Use_Clause 9174 (Associated_Node (N)))) 9175 then 9176 Error_Msg_Node_1 := Entity (N); 9177 Error_Msg_NE 9178 ("use clause for package & has no effect?u?", 9179 Curr, Entity (N)); 9180 end if; 9181 9182 -- We are dealing with an unused use_type_clause 9183 9184 else 9185 Error_Msg_Node_1 := Etype (N); 9186 Error_Msg_NE 9187 ("use clause for } has no effect?u?", Curr, Etype (N)); 9188 end if; 9189 end if; 9190 9191 -- Verify that we haven't already processed a redundant 9192 -- use_type_clause within the same scope before we move the 9193 -- current use clause up to a previous one for type T. 9194 9195 if Present (Prev_Use_Clause (Curr)) then 9196 Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr)); 9197 end if; 9198 9199 Curr := Next_Use_Clause (Curr); 9200 end loop; 9201 end Update_Chain_In_Scope; 9202 9203 -- Start of processing for Update_Use_Clause_Chain 9204 9205 begin 9206 Update_Chain_In_Scope (Scope_Stack.Last); 9207 9208 -- Deal with use clauses within the context area if the current 9209 -- scope is a compilation unit. 9210 9211 if Is_Compilation_Unit (Current_Scope) 9212 and then Sloc (Scope_Stack.Table 9213 (Scope_Stack.Last - 1).Entity) = Standard_Location 9214 then 9215 Update_Chain_In_Scope (Scope_Stack.Last - 1); 9216 end if; 9217 end Update_Use_Clause_Chain; 9218 9219 --------------------- 9220 -- Use_One_Package -- 9221 --------------------- 9222 9223 procedure Use_One_Package 9224 (N : Node_Id; 9225 Pack_Name : Entity_Id := Empty; 9226 Force : Boolean := False) 9227 is 9228 procedure Note_Redundant_Use (Clause : Node_Id); 9229 -- Mark the name in a use clause as redundant if the corresponding 9230 -- entity is already use-visible. Emit a warning if the use clause comes 9231 -- from source and the proper warnings are enabled. 9232 9233 ------------------------ 9234 -- Note_Redundant_Use -- 9235 ------------------------ 9236 9237 procedure Note_Redundant_Use (Clause : Node_Id) is 9238 Decl : constant Node_Id := Parent (Clause); 9239 Pack_Name : constant Entity_Id := Entity (Clause); 9240 9241 Cur_Use : Node_Id := Current_Use_Clause (Pack_Name); 9242 Prev_Use : Node_Id := Empty; 9243 Redundant : Node_Id := Empty; 9244 -- The Use_Clause which is actually redundant. In the simplest case 9245 -- it is Pack itself, but when we compile a body we install its 9246 -- context before that of its spec, in which case it is the 9247 -- use_clause in the spec that will appear to be redundant, and we 9248 -- want the warning to be placed on the body. Similar complications 9249 -- appear when the redundancy is between a child unit and one of its 9250 -- ancestors. 9251 9252 begin 9253 -- Could be renamed... 9254 9255 if No (Cur_Use) then 9256 Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name)); 9257 end if; 9258 9259 Set_Redundant_Use (Clause, True); 9260 9261 if not Comes_From_Source (Clause) 9262 or else In_Instance 9263 or else not Warn_On_Redundant_Constructs 9264 then 9265 return; 9266 end if; 9267 9268 if not Is_Compilation_Unit (Current_Scope) then 9269 9270 -- If the use_clause is in an inner scope, it is made redundant by 9271 -- some clause in the current context, with one exception: If we 9272 -- are compiling a nested package body, and the use_clause comes 9273 -- from then corresponding spec, the clause is not necessarily 9274 -- fully redundant, so we should not warn. If a warning was 9275 -- warranted, it would have been given when the spec was 9276 -- processed. 9277 9278 if Nkind (Parent (Decl)) = N_Package_Specification then 9279 declare 9280 Package_Spec_Entity : constant Entity_Id := 9281 Defining_Unit_Name (Parent (Decl)); 9282 begin 9283 if In_Package_Body (Package_Spec_Entity) then 9284 return; 9285 end if; 9286 end; 9287 end if; 9288 9289 Redundant := Clause; 9290 Prev_Use := Cur_Use; 9291 9292 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then 9293 declare 9294 Cur_Unit : constant Unit_Number_Type := 9295 Get_Source_Unit (Cur_Use); 9296 New_Unit : constant Unit_Number_Type := 9297 Get_Source_Unit (Clause); 9298 9299 Scop : Entity_Id; 9300 9301 begin 9302 if Cur_Unit = New_Unit then 9303 9304 -- Redundant clause in same body 9305 9306 Redundant := Clause; 9307 Prev_Use := Cur_Use; 9308 9309 elsif Cur_Unit = Current_Sem_Unit then 9310 9311 -- If the new clause is not in the current unit it has been 9312 -- analyzed first, and it makes the other one redundant. 9313 -- However, if the new clause appears in a subunit, Cur_Unit 9314 -- is still the parent, and in that case the redundant one 9315 -- is the one appearing in the subunit. 9316 9317 if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then 9318 Redundant := Clause; 9319 Prev_Use := Cur_Use; 9320 9321 -- Most common case: redundant clause in body, original 9322 -- clause in spec. Current scope is spec entity. 9323 9324 elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then 9325 Redundant := Cur_Use; 9326 Prev_Use := Clause; 9327 9328 else 9329 -- The new clause may appear in an unrelated unit, when 9330 -- the parents of a generic are being installed prior to 9331 -- instantiation. In this case there must be no warning. 9332 -- We detect this case by checking whether the current 9333 -- top of the stack is related to the current 9334 -- compilation. 9335 9336 Scop := Current_Scope; 9337 while Present (Scop) 9338 and then Scop /= Standard_Standard 9339 loop 9340 if Is_Compilation_Unit (Scop) 9341 and then not Is_Child_Unit (Scop) 9342 then 9343 return; 9344 9345 elsif Scop = Cunit_Entity (Current_Sem_Unit) then 9346 exit; 9347 end if; 9348 9349 Scop := Scope (Scop); 9350 end loop; 9351 9352 Redundant := Cur_Use; 9353 Prev_Use := Clause; 9354 end if; 9355 9356 elsif New_Unit = Current_Sem_Unit then 9357 Redundant := Clause; 9358 Prev_Use := Cur_Use; 9359 9360 else 9361 -- Neither is the current unit, so they appear in parent or 9362 -- sibling units. Warning will be emitted elsewhere. 9363 9364 return; 9365 end if; 9366 end; 9367 9368 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 9369 and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) 9370 then 9371 -- Use_clause is in child unit of current unit, and the child unit 9372 -- appears in the context of the body of the parent, so it has 9373 -- been installed first, even though it is the redundant one. 9374 -- Depending on their placement in the context, the visible or the 9375 -- private parts of the two units, either might appear as 9376 -- redundant, but the message has to be on the current unit. 9377 9378 if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then 9379 Redundant := Cur_Use; 9380 Prev_Use := Clause; 9381 else 9382 Redundant := Clause; 9383 Prev_Use := Cur_Use; 9384 end if; 9385 9386 -- If the new use clause appears in the private part of a parent 9387 -- unit it may appear to be redundant w.r.t. a use clause in a 9388 -- child unit, but the previous use clause was needed in the 9389 -- visible part of the child, and no warning should be emitted. 9390 9391 if Nkind (Parent (Decl)) = N_Package_Specification 9392 and then List_Containing (Decl) = 9393 Private_Declarations (Parent (Decl)) 9394 then 9395 declare 9396 Par : constant Entity_Id := Defining_Entity (Parent (Decl)); 9397 Spec : constant Node_Id := 9398 Specification (Unit (Cunit (Current_Sem_Unit))); 9399 9400 begin 9401 if Is_Compilation_Unit (Par) 9402 and then Par /= Cunit_Entity (Current_Sem_Unit) 9403 and then Parent (Cur_Use) = Spec 9404 and then List_Containing (Cur_Use) = 9405 Visible_Declarations (Spec) 9406 then 9407 return; 9408 end if; 9409 end; 9410 end if; 9411 9412 -- Finally, if the current use clause is in the context then the 9413 -- clause is redundant when it is nested within the unit. 9414 9415 elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit 9416 and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit 9417 and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) 9418 then 9419 Redundant := Clause; 9420 Prev_Use := Cur_Use; 9421 9422 end if; 9423 9424 if Present (Redundant) and then Parent (Redundant) /= Prev_Use then 9425 9426 -- Make sure we are looking at most-descendant use_package_clause 9427 -- by traversing the chain with Find_Most_Prev and then verifying 9428 -- there is no scope manipulation via Most_Descendant_Use_Clause. 9429 9430 if Nkind (Prev_Use) = N_Use_Package_Clause 9431 and then 9432 (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit 9433 or else Most_Descendant_Use_Clause 9434 (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use) 9435 then 9436 Prev_Use := Find_Most_Prev (Prev_Use); 9437 end if; 9438 9439 Error_Msg_Sloc := Sloc (Prev_Use); 9440 Error_Msg_NE -- CODEFIX 9441 ("& is already use-visible through previous use_clause #??", 9442 Redundant, Pack_Name); 9443 end if; 9444 end Note_Redundant_Use; 9445 9446 -- Local variables 9447 9448 Current_Instance : Entity_Id := Empty; 9449 Id : Entity_Id; 9450 P : Entity_Id; 9451 Prev : Entity_Id; 9452 Private_With_OK : Boolean := False; 9453 Real_P : Entity_Id; 9454 9455 -- Start of processing for Use_One_Package 9456 9457 begin 9458 -- Use_One_Package may have been called recursively to handle an 9459 -- implicit use for a auxiliary system package, so set P accordingly 9460 -- and skip redundancy checks. 9461 9462 if No (Pack_Name) and then Present_System_Aux (N) then 9463 P := System_Aux_Id; 9464 9465 -- Check for redundant use_package_clauses 9466 9467 else 9468 -- Ignore cases where we are dealing with a non user defined package 9469 -- like Standard_Standard or something other than a valid package. 9470 9471 if not Is_Entity_Name (Pack_Name) 9472 or else No (Entity (Pack_Name)) 9473 or else Ekind (Entity (Pack_Name)) /= E_Package 9474 then 9475 return; 9476 end if; 9477 9478 -- When a renaming exists we must check it for redundancy. The 9479 -- original package would have already been seen at this point. 9480 9481 if Present (Renamed_Object (Entity (Pack_Name))) then 9482 P := Renamed_Object (Entity (Pack_Name)); 9483 else 9484 P := Entity (Pack_Name); 9485 end if; 9486 9487 -- Check for redundant clauses then set the current use clause for 9488 -- P if were are not "forcing" an installation from a scope 9489 -- reinstallation that is done throughout analysis for various 9490 -- reasons. 9491 9492 if In_Use (P) then 9493 Note_Redundant_Use (Pack_Name); 9494 9495 if not Force then 9496 Set_Current_Use_Clause (P, N); 9497 end if; 9498 9499 return; 9500 9501 -- Warn about detected redundant clauses 9502 9503 elsif not Force 9504 and then In_Open_Scopes (P) 9505 and then not Is_Hidden_Open_Scope (P) 9506 then 9507 if Warn_On_Redundant_Constructs and then P = Current_Scope then 9508 Error_Msg_NE -- CODEFIX 9509 ("& is already use-visible within itself?r?", 9510 Pack_Name, P); 9511 end if; 9512 9513 return; 9514 end if; 9515 9516 -- Set P back to the non-renamed package so that visiblilty of the 9517 -- entities within the package can be properly set below. 9518 9519 P := Entity (Pack_Name); 9520 end if; 9521 9522 Set_In_Use (P); 9523 Set_Current_Use_Clause (P, N); 9524 9525 -- Ada 2005 (AI-50217): Check restriction 9526 9527 if From_Limited_With (P) then 9528 Error_Msg_N ("limited withed package cannot appear in use clause", N); 9529 end if; 9530 9531 -- Find enclosing instance, if any 9532 9533 if In_Instance then 9534 Current_Instance := Current_Scope; 9535 while not Is_Generic_Instance (Current_Instance) loop 9536 Current_Instance := Scope (Current_Instance); 9537 end loop; 9538 9539 if No (Hidden_By_Use_Clause (N)) then 9540 Set_Hidden_By_Use_Clause (N, New_Elmt_List); 9541 end if; 9542 end if; 9543 9544 -- If unit is a package renaming, indicate that the renamed package is 9545 -- also in use (the flags on both entities must remain consistent, and a 9546 -- subsequent use of either of them should be recognized as redundant). 9547 9548 if Present (Renamed_Object (P)) then 9549 Set_In_Use (Renamed_Object (P)); 9550 Set_Current_Use_Clause (Renamed_Object (P), N); 9551 Real_P := Renamed_Object (P); 9552 else 9553 Real_P := P; 9554 end if; 9555 9556 -- Ada 2005 (AI-262): Check the use_clause of a private withed package 9557 -- found in the private part of a package specification 9558 9559 if In_Private_Part (Current_Scope) 9560 and then Has_Private_With (P) 9561 and then Is_Child_Unit (Current_Scope) 9562 and then Is_Child_Unit (P) 9563 and then Is_Ancestor_Package (Scope (Current_Scope), P) 9564 then 9565 Private_With_OK := True; 9566 end if; 9567 9568 -- Loop through entities in one package making them potentially 9569 -- use-visible. 9570 9571 Id := First_Entity (P); 9572 while Present (Id) 9573 and then (Id /= First_Private_Entity (P) 9574 or else Private_With_OK) -- Ada 2005 (AI-262) 9575 loop 9576 Prev := Current_Entity (Id); 9577 while Present (Prev) loop 9578 if Is_Immediately_Visible (Prev) 9579 and then (not Is_Overloadable (Prev) 9580 or else not Is_Overloadable (Id) 9581 or else (Type_Conformant (Id, Prev))) 9582 then 9583 if No (Current_Instance) then 9584 9585 -- Potentially use-visible entity remains hidden 9586 9587 goto Next_Usable_Entity; 9588 9589 -- A use clause within an instance hides outer global entities, 9590 -- which are not used to resolve local entities in the 9591 -- instance. Note that the predefined entities in Standard 9592 -- could not have been hidden in the generic by a use clause, 9593 -- and therefore remain visible. Other compilation units whose 9594 -- entities appear in Standard must be hidden in an instance. 9595 9596 -- To determine whether an entity is external to the instance 9597 -- we compare the scope depth of its scope with that of the 9598 -- current instance. However, a generic actual of a subprogram 9599 -- instance is declared in the wrapper package but will not be 9600 -- hidden by a use-visible entity. similarly, an entity that is 9601 -- declared in an enclosing instance will not be hidden by an 9602 -- an entity declared in a generic actual, which can only have 9603 -- been use-visible in the generic and will not have hidden the 9604 -- entity in the generic parent. 9605 9606 -- If Id is called Standard, the predefined package with the 9607 -- same name is in the homonym chain. It has to be ignored 9608 -- because it has no defined scope (being the only entity in 9609 -- the system with this mandated behavior). 9610 9611 elsif not Is_Hidden (Id) 9612 and then Present (Scope (Prev)) 9613 and then not Is_Wrapper_Package (Scope (Prev)) 9614 and then Scope_Depth (Scope (Prev)) < 9615 Scope_Depth (Current_Instance) 9616 and then (Scope (Prev) /= Standard_Standard 9617 or else Sloc (Prev) > Standard_Location) 9618 then 9619 if In_Open_Scopes (Scope (Prev)) 9620 and then Is_Generic_Instance (Scope (Prev)) 9621 and then Present (Associated_Formal_Package (P)) 9622 then 9623 null; 9624 9625 else 9626 Set_Is_Potentially_Use_Visible (Id); 9627 Set_Is_Immediately_Visible (Prev, False); 9628 Append_Elmt (Prev, Hidden_By_Use_Clause (N)); 9629 end if; 9630 end if; 9631 9632 -- A user-defined operator is not use-visible if the predefined 9633 -- operator for the type is immediately visible, which is the case 9634 -- if the type of the operand is in an open scope. This does not 9635 -- apply to user-defined operators that have operands of different 9636 -- types, because the predefined mixed mode operations (multiply 9637 -- and divide) apply to universal types and do not hide anything. 9638 9639 elsif Ekind (Prev) = E_Operator 9640 and then Operator_Matches_Spec (Prev, Id) 9641 and then In_Open_Scopes 9642 (Scope (Base_Type (Etype (First_Formal (Id))))) 9643 and then (No (Next_Formal (First_Formal (Id))) 9644 or else Etype (First_Formal (Id)) = 9645 Etype (Next_Formal (First_Formal (Id))) 9646 or else Chars (Prev) = Name_Op_Expon) 9647 then 9648 goto Next_Usable_Entity; 9649 9650 -- In an instance, two homonyms may become use_visible through the 9651 -- actuals of distinct formal packages. In the generic, only the 9652 -- current one would have been visible, so make the other one 9653 -- not use_visible. 9654 9655 elsif Present (Current_Instance) 9656 and then Is_Potentially_Use_Visible (Prev) 9657 and then not Is_Overloadable (Prev) 9658 and then Scope (Id) /= Scope (Prev) 9659 and then Used_As_Generic_Actual (Scope (Prev)) 9660 and then Used_As_Generic_Actual (Scope (Id)) 9661 and then not In_Same_List (Current_Use_Clause (Scope (Prev)), 9662 Current_Use_Clause (Scope (Id))) 9663 then 9664 Set_Is_Potentially_Use_Visible (Prev, False); 9665 Append_Elmt (Prev, Hidden_By_Use_Clause (N)); 9666 end if; 9667 9668 Prev := Homonym (Prev); 9669 end loop; 9670 9671 -- On exit, we know entity is not hidden, unless it is private 9672 9673 if not Is_Hidden (Id) 9674 and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id)) 9675 then 9676 Set_Is_Potentially_Use_Visible (Id); 9677 9678 if Is_Private_Type (Id) and then Present (Full_View (Id)) then 9679 Set_Is_Potentially_Use_Visible (Full_View (Id)); 9680 end if; 9681 end if; 9682 9683 <<Next_Usable_Entity>> 9684 Next_Entity (Id); 9685 end loop; 9686 9687 -- Child units are also made use-visible by a use clause, but they may 9688 -- appear after all visible declarations in the parent entity list. 9689 9690 while Present (Id) loop 9691 if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then 9692 Set_Is_Potentially_Use_Visible (Id); 9693 end if; 9694 9695 Next_Entity (Id); 9696 end loop; 9697 9698 if Chars (Real_P) = Name_System 9699 and then Scope (Real_P) = Standard_Standard 9700 and then Present_System_Aux (N) 9701 then 9702 Use_One_Package (N); 9703 end if; 9704 end Use_One_Package; 9705 9706 ------------------ 9707 -- Use_One_Type -- 9708 ------------------ 9709 9710 procedure Use_One_Type 9711 (Id : Node_Id; 9712 Installed : Boolean := False; 9713 Force : Boolean := False) 9714 is 9715 function Spec_Reloaded_For_Body return Boolean; 9716 -- Determine whether the compilation unit is a package body and the use 9717 -- type clause is in the spec of the same package. Even though the spec 9718 -- was analyzed first, its context is reloaded when analysing the body. 9719 9720 procedure Use_Class_Wide_Operations (Typ : Entity_Id); 9721 -- AI05-150: if the use_type_clause carries the "all" qualifier, 9722 -- class-wide operations of ancestor types are use-visible if the 9723 -- ancestor type is visible. 9724 9725 ---------------------------- 9726 -- Spec_Reloaded_For_Body -- 9727 ---------------------------- 9728 9729 function Spec_Reloaded_For_Body return Boolean is 9730 begin 9731 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then 9732 declare 9733 Spec : constant Node_Id := 9734 Parent (List_Containing (Parent (Id))); 9735 9736 begin 9737 -- Check whether type is declared in a package specification, 9738 -- and current unit is the corresponding package body. The 9739 -- use clauses themselves may be within a nested package. 9740 9741 return 9742 Nkind (Spec) = N_Package_Specification 9743 and then In_Same_Source_Unit 9744 (Corresponding_Body (Parent (Spec)), 9745 Cunit_Entity (Current_Sem_Unit)); 9746 end; 9747 end if; 9748 9749 return False; 9750 end Spec_Reloaded_For_Body; 9751 9752 ------------------------------- 9753 -- Use_Class_Wide_Operations -- 9754 ------------------------------- 9755 9756 procedure Use_Class_Wide_Operations (Typ : Entity_Id) is 9757 function Is_Class_Wide_Operation_Of 9758 (Op : Entity_Id; 9759 T : Entity_Id) return Boolean; 9760 -- Determine whether a subprogram has a class-wide parameter or 9761 -- result that is T'Class. 9762 9763 --------------------------------- 9764 -- Is_Class_Wide_Operation_Of -- 9765 --------------------------------- 9766 9767 function Is_Class_Wide_Operation_Of 9768 (Op : Entity_Id; 9769 T : Entity_Id) return Boolean 9770 is 9771 Formal : Entity_Id; 9772 9773 begin 9774 Formal := First_Formal (Op); 9775 while Present (Formal) loop 9776 if Etype (Formal) = Class_Wide_Type (T) then 9777 return True; 9778 end if; 9779 9780 Next_Formal (Formal); 9781 end loop; 9782 9783 if Etype (Op) = Class_Wide_Type (T) then 9784 return True; 9785 end if; 9786 9787 return False; 9788 end Is_Class_Wide_Operation_Of; 9789 9790 -- Local variables 9791 9792 Ent : Entity_Id; 9793 Scop : Entity_Id; 9794 9795 -- Start of processing for Use_Class_Wide_Operations 9796 9797 begin 9798 Scop := Scope (Typ); 9799 if not Is_Hidden (Scop) then 9800 Ent := First_Entity (Scop); 9801 while Present (Ent) loop 9802 if Is_Overloadable (Ent) 9803 and then Is_Class_Wide_Operation_Of (Ent, Typ) 9804 and then not Is_Potentially_Use_Visible (Ent) 9805 then 9806 Set_Is_Potentially_Use_Visible (Ent); 9807 Append_Elmt (Ent, Used_Operations (Parent (Id))); 9808 end if; 9809 9810 Next_Entity (Ent); 9811 end loop; 9812 end if; 9813 9814 if Is_Derived_Type (Typ) then 9815 Use_Class_Wide_Operations (Etype (Base_Type (Typ))); 9816 end if; 9817 end Use_Class_Wide_Operations; 9818 9819 -- Local variables 9820 9821 Elmt : Elmt_Id; 9822 Is_Known_Used : Boolean; 9823 Op_List : Elist_Id; 9824 T : Entity_Id; 9825 9826 -- Start of processing for Use_One_Type 9827 9828 begin 9829 if Entity (Id) = Any_Type then 9830 return; 9831 end if; 9832 9833 -- It is the type determined by the subtype mark (8.4(8)) whose 9834 -- operations become potentially use-visible. 9835 9836 T := Base_Type (Entity (Id)); 9837 9838 -- Either the type itself is used, the package where it is declared is 9839 -- in use or the entity is declared in the current package, thus 9840 -- use-visible. 9841 9842 Is_Known_Used := 9843 (In_Use (T) 9844 and then ((Present (Current_Use_Clause (T)) 9845 and then All_Present (Current_Use_Clause (T))) 9846 or else not All_Present (Parent (Id)))) 9847 or else In_Use (Scope (T)) 9848 or else Scope (T) = Current_Scope; 9849 9850 Set_Redundant_Use (Id, 9851 Is_Known_Used or else Is_Potentially_Use_Visible (T)); 9852 9853 if Ekind (T) = E_Incomplete_Type then 9854 Error_Msg_N ("premature usage of incomplete type", Id); 9855 9856 elsif In_Open_Scopes (Scope (T)) then 9857 null; 9858 9859 -- A limited view cannot appear in a use_type_clause. However, an access 9860 -- type whose designated type is limited has the flag but is not itself 9861 -- a limited view unless we only have a limited view of its enclosing 9862 -- package. 9863 9864 elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then 9865 Error_Msg_N 9866 ("incomplete type from limited view cannot appear in use clause", 9867 Id); 9868 9869 -- If the use clause is redundant, Used_Operations will usually be 9870 -- empty, but we need to set it to empty here in one case: If we are 9871 -- instantiating a generic library unit, then we install the ancestors 9872 -- of that unit in the scope stack, which involves reprocessing use 9873 -- clauses in those ancestors. Such a use clause will typically have a 9874 -- nonempty Used_Operations unless it was redundant in the generic unit, 9875 -- even if it is redundant at the place of the instantiation. 9876 9877 elsif Redundant_Use (Id) then 9878 9879 -- We must avoid incorrectly setting the Current_Use_Clause when we 9880 -- are working with a redundant clause that has already been linked 9881 -- in the Prev_Use_Clause chain, otherwise the chain will break. 9882 9883 if Present (Current_Use_Clause (T)) 9884 and then Present (Prev_Use_Clause (Current_Use_Clause (T))) 9885 and then Parent (Id) = Prev_Use_Clause (Current_Use_Clause (T)) 9886 then 9887 null; 9888 else 9889 Set_Current_Use_Clause (T, Parent (Id)); 9890 end if; 9891 9892 Set_Used_Operations (Parent (Id), New_Elmt_List); 9893 9894 -- If the subtype mark designates a subtype in a different package, 9895 -- we have to check that the parent type is visible, otherwise the 9896 -- use_type_clause is a no-op. Not clear how to do that??? 9897 9898 else 9899 Set_Current_Use_Clause (T, Parent (Id)); 9900 Set_In_Use (T); 9901 9902 -- If T is tagged, primitive operators on class-wide operands are 9903 -- also available. 9904 9905 if Is_Tagged_Type (T) then 9906 Set_In_Use (Class_Wide_Type (T)); 9907 end if; 9908 9909 -- Iterate over primitive operations of the type. If an operation is 9910 -- already use_visible, it is the result of a previous use_clause, 9911 -- and already appears on the corresponding entity chain. If the 9912 -- clause is being reinstalled, operations are already use-visible. 9913 9914 if Installed then 9915 null; 9916 9917 else 9918 Op_List := Collect_Primitive_Operations (T); 9919 Elmt := First_Elmt (Op_List); 9920 while Present (Elmt) loop 9921 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol 9922 or else Chars (Node (Elmt)) in Any_Operator_Name) 9923 and then not Is_Hidden (Node (Elmt)) 9924 and then not Is_Potentially_Use_Visible (Node (Elmt)) 9925 then 9926 Set_Is_Potentially_Use_Visible (Node (Elmt)); 9927 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); 9928 9929 elsif Ada_Version >= Ada_2012 9930 and then All_Present (Parent (Id)) 9931 and then not Is_Hidden (Node (Elmt)) 9932 and then not Is_Potentially_Use_Visible (Node (Elmt)) 9933 then 9934 Set_Is_Potentially_Use_Visible (Node (Elmt)); 9935 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); 9936 end if; 9937 9938 Next_Elmt (Elmt); 9939 end loop; 9940 end if; 9941 9942 if Ada_Version >= Ada_2012 9943 and then All_Present (Parent (Id)) 9944 and then Is_Tagged_Type (T) 9945 then 9946 Use_Class_Wide_Operations (T); 9947 end if; 9948 end if; 9949 9950 -- If warning on redundant constructs, check for unnecessary WITH 9951 9952 if not Force 9953 and then Warn_On_Redundant_Constructs 9954 and then Is_Known_Used 9955 9956 -- with P; with P; use P; 9957 -- package P is package X is package body X is 9958 -- type T ... use P.T; 9959 9960 -- The compilation unit is the body of X. GNAT first compiles the 9961 -- spec of X, then proceeds to the body. At that point P is marked 9962 -- as use visible. The analysis then reinstalls the spec along with 9963 -- its context. The use clause P.T is now recognized as redundant, 9964 -- but in the wrong context. Do not emit a warning in such cases. 9965 -- Do not emit a warning either if we are in an instance, there is 9966 -- no redundancy between an outer use_clause and one that appears 9967 -- within the generic. 9968 9969 and then not Spec_Reloaded_For_Body 9970 and then not In_Instance 9971 and then not In_Inlined_Body 9972 then 9973 -- The type already has a use clause 9974 9975 if In_Use (T) then 9976 9977 -- Case where we know the current use clause for the type 9978 9979 if Present (Current_Use_Clause (T)) then 9980 Use_Clause_Known : declare 9981 Clause1 : constant Node_Id := 9982 Find_Most_Prev (Current_Use_Clause (T)); 9983 Clause2 : constant Node_Id := Parent (Id); 9984 Ent1 : Entity_Id; 9985 Ent2 : Entity_Id; 9986 Err_No : Node_Id; 9987 Unit1 : Node_Id; 9988 Unit2 : Node_Id; 9989 9990 -- Start of processing for Use_Clause_Known 9991 9992 begin 9993 -- If both current use_type_clause and the use_type_clause 9994 -- for the type are at the compilation unit level, one of 9995 -- the units must be an ancestor of the other, and the 9996 -- warning belongs on the descendant. 9997 9998 if Nkind (Parent (Clause1)) = N_Compilation_Unit 9999 and then 10000 Nkind (Parent (Clause2)) = N_Compilation_Unit 10001 then 10002 -- If the unit is a subprogram body that acts as spec, 10003 -- the context clause is shared with the constructed 10004 -- subprogram spec. Clearly there is no redundancy. 10005 10006 if Clause1 = Clause2 then 10007 return; 10008 end if; 10009 10010 Unit1 := Unit (Parent (Clause1)); 10011 Unit2 := Unit (Parent (Clause2)); 10012 10013 -- If both clauses are on same unit, or one is the body 10014 -- of the other, or one of them is in a subunit, report 10015 -- redundancy on the later one. 10016 10017 if Unit1 = Unit2 or else Nkind (Unit1) = N_Subunit then 10018 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10019 Error_Msg_NE -- CODEFIX 10020 ("& is already use-visible through previous " 10021 & "use_type_clause #??", Clause1, T); 10022 return; 10023 10024 elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body) 10025 and then Nkind (Unit1) /= Nkind (Unit2) 10026 and then Nkind (Unit1) /= N_Subunit 10027 then 10028 Error_Msg_Sloc := Sloc (Clause1); 10029 Error_Msg_NE -- CODEFIX 10030 ("& is already use-visible through previous " 10031 & "use_type_clause #??", Current_Use_Clause (T), T); 10032 return; 10033 end if; 10034 10035 -- There is a redundant use_type_clause in a child unit. 10036 -- Determine which of the units is more deeply nested. 10037 -- If a unit is a package instance, retrieve the entity 10038 -- and its scope from the instance spec. 10039 10040 Ent1 := Entity_Of_Unit (Unit1); 10041 Ent2 := Entity_Of_Unit (Unit2); 10042 10043 if Scope (Ent2) = Standard_Standard then 10044 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10045 Err_No := Clause1; 10046 10047 elsif Scope (Ent1) = Standard_Standard then 10048 Error_Msg_Sloc := Sloc (Id); 10049 Err_No := Clause2; 10050 10051 -- If both units are child units, we determine which one 10052 -- is the descendant by the scope distance to the 10053 -- ultimate parent unit. 10054 10055 else 10056 declare 10057 S1 : Entity_Id; 10058 S2 : Entity_Id; 10059 10060 begin 10061 S1 := Scope (Ent1); 10062 S2 := Scope (Ent2); 10063 while Present (S1) 10064 and then Present (S2) 10065 and then S1 /= Standard_Standard 10066 and then S2 /= Standard_Standard 10067 loop 10068 S1 := Scope (S1); 10069 S2 := Scope (S2); 10070 end loop; 10071 10072 if S1 = Standard_Standard then 10073 Error_Msg_Sloc := Sloc (Id); 10074 Err_No := Clause2; 10075 else 10076 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10077 Err_No := Clause1; 10078 end if; 10079 end; 10080 end if; 10081 10082 if Parent (Id) /= Err_No then 10083 if Most_Descendant_Use_Clause 10084 (Err_No, Parent (Id)) = Parent (Id) 10085 then 10086 Error_Msg_Sloc := Sloc (Err_No); 10087 Err_No := Parent (Id); 10088 end if; 10089 10090 Error_Msg_NE -- CODEFIX 10091 ("& is already use-visible through previous " 10092 & "use_type_clause #??", Err_No, Id); 10093 end if; 10094 10095 -- Case where current use_type_clause and use_type_clause 10096 -- for the type are not both at the compilation unit level. 10097 -- In this case we don't have location information. 10098 10099 else 10100 Error_Msg_NE -- CODEFIX 10101 ("& is already use-visible through previous " 10102 & "use_type_clause??", Id, T); 10103 end if; 10104 end Use_Clause_Known; 10105 10106 -- Here if Current_Use_Clause is not set for T, another case where 10107 -- we do not have the location information available. 10108 10109 else 10110 Error_Msg_NE -- CODEFIX 10111 ("& is already use-visible through previous " 10112 & "use_type_clause??", Id, T); 10113 end if; 10114 10115 -- The package where T is declared is already used 10116 10117 elsif In_Use (Scope (T)) then 10118 Error_Msg_Sloc := 10119 Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T)))); 10120 Error_Msg_NE -- CODEFIX 10121 ("& is already use-visible through package use clause #??", 10122 Id, T); 10123 10124 -- The current scope is the package where T is declared 10125 10126 else 10127 Error_Msg_Node_2 := Scope (T); 10128 Error_Msg_NE -- CODEFIX 10129 ("& is already use-visible inside package &??", Id, T); 10130 end if; 10131 end if; 10132 end Use_One_Type; 10133 10134 ---------------- 10135 -- Write_Info -- 10136 ---------------- 10137 10138 procedure Write_Info is 10139 Id : Entity_Id := First_Entity (Current_Scope); 10140 10141 begin 10142 -- No point in dumping standard entities 10143 10144 if Current_Scope = Standard_Standard then 10145 return; 10146 end if; 10147 10148 Write_Str ("========================================================"); 10149 Write_Eol; 10150 Write_Str (" Defined Entities in "); 10151 Write_Name (Chars (Current_Scope)); 10152 Write_Eol; 10153 Write_Str ("========================================================"); 10154 Write_Eol; 10155 10156 if No (Id) then 10157 Write_Str ("-- none --"); 10158 Write_Eol; 10159 10160 else 10161 while Present (Id) loop 10162 Write_Entity_Info (Id, " "); 10163 Next_Entity (Id); 10164 end loop; 10165 end if; 10166 10167 if Scope (Current_Scope) = Standard_Standard then 10168 10169 -- Print information on the current unit itself 10170 10171 Write_Entity_Info (Current_Scope, " "); 10172 end if; 10173 10174 Write_Eol; 10175 end Write_Info; 10176 10177 -------- 10178 -- ws -- 10179 -------- 10180 10181 procedure ws is 10182 S : Entity_Id; 10183 begin 10184 for J in reverse 1 .. Scope_Stack.Last loop 10185 S := Scope_Stack.Table (J).Entity; 10186 Write_Int (Int (S)); 10187 Write_Str (" === "); 10188 Write_Name (Chars (S)); 10189 Write_Eol; 10190 end loop; 10191 end ws; 10192 10193 -------- 10194 -- we -- 10195 -------- 10196 10197 procedure we (S : Entity_Id) is 10198 E : Entity_Id; 10199 begin 10200 E := First_Entity (S); 10201 while Present (E) loop 10202 Write_Int (Int (E)); 10203 Write_Str (" === "); 10204 Write_Name (Chars (E)); 10205 Write_Eol; 10206 Next_Entity (E); 10207 end loop; 10208 end we; 10209end Sem_Ch8; 10210