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