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