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 (N => Parent (N), 4260 Empty_On_Errors => True) = Current_Scope 4261 then 4262 null; 4263 4264 else 4265 -- If declaration appears in some other scope, it must be in some 4266 -- parent unit when compiling a child. 4267 4268 Pack := Defining_Entity (Parent (N), Empty_On_Errors => True); 4269 4270 if not In_Open_Scopes (Pack) then 4271 null; 4272 4273 -- If the use clause appears in an ancestor and we are in the 4274 -- private part of the immediate parent, the use clauses are 4275 -- already installed. 4276 4277 elsif Pack /= Scope (Current_Scope) 4278 and then In_Private_Part (Scope (Current_Scope)) 4279 then 4280 null; 4281 4282 else 4283 -- Find entry for parent unit in scope stack 4284 4285 while Scope_Stack.Table (Level).Entity /= Pack loop 4286 Level := Level - 1; 4287 end loop; 4288 end if; 4289 end if; 4290 4291 Set_Next_Use_Clause (N, 4292 Scope_Stack.Table (Level).First_Use_Clause); 4293 Scope_Stack.Table (Level).First_Use_Clause := N; 4294 end Chain_Use_Clause; 4295 4296 --------------------------- 4297 -- Check_Frozen_Renaming -- 4298 --------------------------- 4299 4300 procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is 4301 B_Node : Node_Id; 4302 Old_S : Entity_Id; 4303 4304 begin 4305 if Is_Frozen (Subp) and then not Has_Completion (Subp) then 4306 B_Node := 4307 Build_Renamed_Body 4308 (Parent (Declaration_Node (Subp)), Defining_Entity (N)); 4309 4310 if Is_Entity_Name (Name (N)) then 4311 Old_S := Entity (Name (N)); 4312 4313 if not Is_Frozen (Old_S) 4314 and then Operating_Mode /= Check_Semantics 4315 then 4316 Append_Freeze_Action (Old_S, B_Node); 4317 else 4318 Insert_After (N, B_Node); 4319 Analyze (B_Node); 4320 end if; 4321 4322 if Is_Intrinsic_Subprogram (Old_S) 4323 and then not In_Instance 4324 and then not Relaxed_RM_Semantics 4325 then 4326 Error_Msg_N 4327 ("subprogram used in renaming_as_body cannot be intrinsic", 4328 Name (N)); 4329 end if; 4330 4331 else 4332 Insert_After (N, B_Node); 4333 Analyze (B_Node); 4334 end if; 4335 end if; 4336 end Check_Frozen_Renaming; 4337 4338 ------------------------------- 4339 -- Set_Entity_Or_Discriminal -- 4340 ------------------------------- 4341 4342 procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is 4343 P : Node_Id; 4344 4345 begin 4346 -- If the entity is not a discriminant, or else expansion is disabled, 4347 -- simply set the entity. 4348 4349 if not In_Spec_Expression 4350 or else Ekind (E) /= E_Discriminant 4351 or else Inside_A_Generic 4352 then 4353 Set_Entity_With_Checks (N, E); 4354 4355 -- The replacement of a discriminant by the corresponding discriminal 4356 -- is not done for a task discriminant that appears in a default 4357 -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant 4358 -- for details on their handling. 4359 4360 elsif Is_Concurrent_Type (Scope (E)) then 4361 P := Parent (N); 4362 while Present (P) 4363 and then not Nkind_In (P, N_Parameter_Specification, 4364 N_Component_Declaration) 4365 loop 4366 P := Parent (P); 4367 end loop; 4368 4369 if Present (P) 4370 and then Nkind (P) = N_Parameter_Specification 4371 then 4372 null; 4373 4374 else 4375 Set_Entity (N, Discriminal (E)); 4376 end if; 4377 4378 -- Otherwise, this is a discriminant in a context in which 4379 -- it is a reference to the corresponding parameter of the 4380 -- init proc for the enclosing type. 4381 4382 else 4383 Set_Entity (N, Discriminal (E)); 4384 end if; 4385 end Set_Entity_Or_Discriminal; 4386 4387 ----------------------------------- 4388 -- Check_In_Previous_With_Clause -- 4389 ----------------------------------- 4390 4391 procedure Check_In_Previous_With_Clause 4392 (N : Node_Id; 4393 Nam : Entity_Id) 4394 is 4395 Pack : constant Entity_Id := Entity (Original_Node (Nam)); 4396 Item : Node_Id; 4397 Par : Node_Id; 4398 4399 begin 4400 Item := First (Context_Items (Parent (N))); 4401 while Present (Item) and then Item /= N loop 4402 if Nkind (Item) = N_With_Clause 4403 4404 -- Protect the frontend against previous critical errors 4405 4406 and then Nkind (Name (Item)) /= N_Selected_Component 4407 and then Entity (Name (Item)) = Pack 4408 then 4409 Par := Nam; 4410 4411 -- Find root library unit in with_clause 4412 4413 while Nkind (Par) = N_Expanded_Name loop 4414 Par := Prefix (Par); 4415 end loop; 4416 4417 if Is_Child_Unit (Entity (Original_Node (Par))) then 4418 Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); 4419 else 4420 return; 4421 end if; 4422 end if; 4423 4424 Next (Item); 4425 end loop; 4426 4427 -- On exit, package is not mentioned in a previous with_clause. 4428 -- Check if its prefix is. 4429 4430 if Nkind (Nam) = N_Expanded_Name then 4431 Check_In_Previous_With_Clause (N, Prefix (Nam)); 4432 4433 elsif Pack /= Any_Id then 4434 Error_Msg_NE ("& is not visible", Nam, Pack); 4435 end if; 4436 end Check_In_Previous_With_Clause; 4437 4438 --------------------------------- 4439 -- Check_Library_Unit_Renaming -- 4440 --------------------------------- 4441 4442 procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is 4443 New_E : Entity_Id; 4444 4445 begin 4446 if Nkind (Parent (N)) /= N_Compilation_Unit then 4447 return; 4448 4449 -- Check for library unit. Note that we used to check for the scope 4450 -- being Standard here, but that was wrong for Standard itself. 4451 4452 elsif not Is_Compilation_Unit (Old_E) 4453 and then not Is_Child_Unit (Old_E) 4454 then 4455 Error_Msg_N ("renamed unit must be a library unit", Name (N)); 4456 4457 -- Entities defined in Standard (operators and boolean literals) cannot 4458 -- be renamed as library units. 4459 4460 elsif Scope (Old_E) = Standard_Standard 4461 and then Sloc (Old_E) = Standard_Location 4462 then 4463 Error_Msg_N ("renamed unit must be a library unit", Name (N)); 4464 4465 elsif Present (Parent_Spec (N)) 4466 and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration 4467 and then not Is_Child_Unit (Old_E) 4468 then 4469 Error_Msg_N 4470 ("renamed unit must be a child unit of generic parent", Name (N)); 4471 4472 elsif Nkind (N) in N_Generic_Renaming_Declaration 4473 and then Nkind (Name (N)) = N_Expanded_Name 4474 and then Is_Generic_Instance (Entity (Prefix (Name (N)))) 4475 and then Is_Generic_Unit (Old_E) 4476 then 4477 Error_Msg_N 4478 ("renamed generic unit must be a library unit", Name (N)); 4479 4480 elsif Is_Package_Or_Generic_Package (Old_E) then 4481 4482 -- Inherit categorization flags 4483 4484 New_E := Defining_Entity (N); 4485 Set_Is_Pure (New_E, Is_Pure (Old_E)); 4486 Set_Is_Preelaborated (New_E, Is_Preelaborated (Old_E)); 4487 Set_Is_Remote_Call_Interface (New_E, 4488 Is_Remote_Call_Interface (Old_E)); 4489 Set_Is_Remote_Types (New_E, Is_Remote_Types (Old_E)); 4490 Set_Is_Shared_Passive (New_E, Is_Shared_Passive (Old_E)); 4491 end if; 4492 end Check_Library_Unit_Renaming; 4493 4494 ------------------------ 4495 -- Enclosing_Instance -- 4496 ------------------------ 4497 4498 function Enclosing_Instance return Entity_Id is 4499 S : Entity_Id; 4500 4501 begin 4502 if not Is_Generic_Instance (Current_Scope) then 4503 return Empty; 4504 end if; 4505 4506 S := Scope (Current_Scope); 4507 while S /= Standard_Standard loop 4508 if Is_Generic_Instance (S) then 4509 return S; 4510 end if; 4511 4512 S := Scope (S); 4513 end loop; 4514 4515 return Empty; 4516 end Enclosing_Instance; 4517 4518 --------------- 4519 -- End_Scope -- 4520 --------------- 4521 4522 procedure End_Scope is 4523 Id : Entity_Id; 4524 Prev : Entity_Id; 4525 Outer : Entity_Id; 4526 4527 begin 4528 Id := First_Entity (Current_Scope); 4529 while Present (Id) loop 4530 -- An entity in the current scope is not necessarily the first one 4531 -- on its homonym chain. Find its predecessor if any, 4532 -- If it is an internal entity, it will not be in the visibility 4533 -- chain altogether, and there is nothing to unchain. 4534 4535 if Id /= Current_Entity (Id) then 4536 Prev := Current_Entity (Id); 4537 while Present (Prev) 4538 and then Present (Homonym (Prev)) 4539 and then Homonym (Prev) /= Id 4540 loop 4541 Prev := Homonym (Prev); 4542 end loop; 4543 4544 -- Skip to end of loop if Id is not in the visibility chain 4545 4546 if No (Prev) or else Homonym (Prev) /= Id then 4547 goto Next_Ent; 4548 end if; 4549 4550 else 4551 Prev := Empty; 4552 end if; 4553 4554 Set_Is_Immediately_Visible (Id, False); 4555 4556 Outer := Homonym (Id); 4557 while Present (Outer) and then Scope (Outer) = Current_Scope loop 4558 Outer := Homonym (Outer); 4559 end loop; 4560 4561 -- Reset homonym link of other entities, but do not modify link 4562 -- between entities in current scope, so that the back-end can have 4563 -- a proper count of local overloadings. 4564 4565 if No (Prev) then 4566 Set_Name_Entity_Id (Chars (Id), Outer); 4567 4568 elsif Scope (Prev) /= Scope (Id) then 4569 Set_Homonym (Prev, Outer); 4570 end if; 4571 4572 <<Next_Ent>> 4573 Next_Entity (Id); 4574 end loop; 4575 4576 -- If the scope generated freeze actions, place them before the 4577 -- current declaration and analyze them. Type declarations and 4578 -- the bodies of initialization procedures can generate such nodes. 4579 -- We follow the parent chain until we reach a list node, which is 4580 -- the enclosing list of declarations. If the list appears within 4581 -- a protected definition, move freeze nodes outside the protected 4582 -- type altogether. 4583 4584 if Present 4585 (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions) 4586 then 4587 declare 4588 Decl : Node_Id; 4589 L : constant List_Id := Scope_Stack.Table 4590 (Scope_Stack.Last).Pending_Freeze_Actions; 4591 4592 begin 4593 if Is_Itype (Current_Scope) then 4594 Decl := Associated_Node_For_Itype (Current_Scope); 4595 else 4596 Decl := Parent (Current_Scope); 4597 end if; 4598 4599 Pop_Scope; 4600 4601 while not (Is_List_Member (Decl)) 4602 or else Nkind_In (Parent (Decl), N_Protected_Definition, 4603 N_Task_Definition) 4604 loop 4605 Decl := Parent (Decl); 4606 end loop; 4607 4608 Insert_List_Before_And_Analyze (Decl, L); 4609 end; 4610 4611 else 4612 Pop_Scope; 4613 end if; 4614 end End_Scope; 4615 4616 --------------------- 4617 -- End_Use_Clauses -- 4618 --------------------- 4619 4620 procedure End_Use_Clauses (Clause : Node_Id) is 4621 U : Node_Id; 4622 4623 begin 4624 -- Remove use_type_clauses first, because they affect the visibility of 4625 -- operators in subsequent used packages. 4626 4627 U := Clause; 4628 while Present (U) loop 4629 if Nkind (U) = N_Use_Type_Clause then 4630 End_Use_Type (U); 4631 end if; 4632 4633 Next_Use_Clause (U); 4634 end loop; 4635 4636 U := Clause; 4637 while Present (U) loop 4638 if Nkind (U) = N_Use_Package_Clause then 4639 End_Use_Package (U); 4640 end if; 4641 4642 Next_Use_Clause (U); 4643 end loop; 4644 end End_Use_Clauses; 4645 4646 --------------------- 4647 -- End_Use_Package -- 4648 --------------------- 4649 4650 procedure End_Use_Package (N : Node_Id) is 4651 Pack : Entity_Id; 4652 Pack_Name : Node_Id; 4653 Id : Entity_Id; 4654 Elmt : Elmt_Id; 4655 4656 function Is_Primitive_Operator_In_Use 4657 (Op : Entity_Id; 4658 F : Entity_Id) return Boolean; 4659 -- Check whether Op is a primitive operator of a use-visible type 4660 4661 ---------------------------------- 4662 -- Is_Primitive_Operator_In_Use -- 4663 ---------------------------------- 4664 4665 function Is_Primitive_Operator_In_Use 4666 (Op : Entity_Id; 4667 F : Entity_Id) return Boolean 4668 is 4669 T : constant Entity_Id := Base_Type (Etype (F)); 4670 begin 4671 return In_Use (T) and then Scope (T) = Scope (Op); 4672 end Is_Primitive_Operator_In_Use; 4673 4674 -- Start of processing for End_Use_Package 4675 4676 begin 4677 Pack_Name := Name (N); 4678 4679 -- Test that Pack_Name actually denotes a package before processing 4680 4681 if Is_Entity_Name (Pack_Name) 4682 and then Ekind (Entity (Pack_Name)) = E_Package 4683 then 4684 Pack := Entity (Pack_Name); 4685 4686 if In_Open_Scopes (Pack) then 4687 null; 4688 4689 elsif not Redundant_Use (Pack_Name) then 4690 Set_In_Use (Pack, False); 4691 Set_Current_Use_Clause (Pack, Empty); 4692 4693 Id := First_Entity (Pack); 4694 while Present (Id) loop 4695 4696 -- Preserve use-visibility of operators that are primitive 4697 -- operators of a type that is use-visible through an active 4698 -- use_type_clause. 4699 4700 if Nkind (Id) = N_Defining_Operator_Symbol 4701 and then 4702 (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) 4703 or else 4704 (Present (Next_Formal (First_Formal (Id))) 4705 and then 4706 Is_Primitive_Operator_In_Use 4707 (Id, Next_Formal (First_Formal (Id))))) 4708 then 4709 null; 4710 else 4711 Set_Is_Potentially_Use_Visible (Id, False); 4712 end if; 4713 4714 if Is_Private_Type (Id) 4715 and then Present (Full_View (Id)) 4716 then 4717 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 4718 end if; 4719 4720 Next_Entity (Id); 4721 end loop; 4722 4723 if Present (Renamed_Object (Pack)) then 4724 Set_In_Use (Renamed_Object (Pack), False); 4725 Set_Current_Use_Clause (Renamed_Object (Pack), Empty); 4726 end if; 4727 4728 if Chars (Pack) = Name_System 4729 and then Scope (Pack) = Standard_Standard 4730 and then Present_System_Aux 4731 then 4732 Id := First_Entity (System_Aux_Id); 4733 while Present (Id) loop 4734 Set_Is_Potentially_Use_Visible (Id, False); 4735 4736 if Is_Private_Type (Id) 4737 and then Present (Full_View (Id)) 4738 then 4739 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 4740 end if; 4741 4742 Next_Entity (Id); 4743 end loop; 4744 4745 Set_In_Use (System_Aux_Id, False); 4746 end if; 4747 else 4748 Set_Redundant_Use (Pack_Name, False); 4749 end if; 4750 end if; 4751 4752 if Present (Hidden_By_Use_Clause (N)) then 4753 Elmt := First_Elmt (Hidden_By_Use_Clause (N)); 4754 while Present (Elmt) loop 4755 declare 4756 E : constant Entity_Id := Node (Elmt); 4757 4758 begin 4759 -- Reset either Use_Visibility or Direct_Visibility, depending 4760 -- on how the entity was hidden by the use clause. 4761 4762 if In_Use (Scope (E)) 4763 and then Used_As_Generic_Actual (Scope (E)) 4764 then 4765 Set_Is_Potentially_Use_Visible (Node (Elmt)); 4766 else 4767 Set_Is_Immediately_Visible (Node (Elmt)); 4768 end if; 4769 4770 Next_Elmt (Elmt); 4771 end; 4772 end loop; 4773 4774 Set_Hidden_By_Use_Clause (N, No_Elist); 4775 end if; 4776 end End_Use_Package; 4777 4778 ------------------ 4779 -- End_Use_Type -- 4780 ------------------ 4781 4782 procedure End_Use_Type (N : Node_Id) is 4783 Elmt : Elmt_Id; 4784 Id : Entity_Id; 4785 T : Entity_Id; 4786 4787 -- Start of processing for End_Use_Type 4788 4789 begin 4790 Id := Subtype_Mark (N); 4791 4792 -- A call to Rtsfind may occur while analyzing a use_type_clause, in 4793 -- which case the type marks are not resolved yet, so guard against that 4794 -- here. 4795 4796 if Is_Entity_Name (Id) and then Present (Entity (Id)) then 4797 T := Entity (Id); 4798 4799 if T = Any_Type or else From_Limited_With (T) then 4800 null; 4801 4802 -- Note that the use_type_clause may mention a subtype of the type 4803 -- whose primitive operations have been made visible. Here as 4804 -- elsewhere, it is the base type that matters for visibility. 4805 4806 elsif In_Open_Scopes (Scope (Base_Type (T))) then 4807 null; 4808 4809 elsif not Redundant_Use (Id) then 4810 Set_In_Use (T, False); 4811 Set_In_Use (Base_Type (T), False); 4812 Set_Current_Use_Clause (T, Empty); 4813 Set_Current_Use_Clause (Base_Type (T), Empty); 4814 end if; 4815 end if; 4816 4817 if Is_Empty_Elmt_List (Used_Operations (N)) then 4818 return; 4819 4820 else 4821 Elmt := First_Elmt (Used_Operations (N)); 4822 while Present (Elmt) loop 4823 Set_Is_Potentially_Use_Visible (Node (Elmt), False); 4824 Next_Elmt (Elmt); 4825 end loop; 4826 end if; 4827 end End_Use_Type; 4828 4829 -------------------- 4830 -- Entity_Of_Unit -- 4831 -------------------- 4832 4833 function Entity_Of_Unit (U : Node_Id) return Entity_Id is 4834 begin 4835 if Nkind (U) = N_Package_Instantiation and then Analyzed (U) then 4836 return Defining_Entity (Instance_Spec (U)); 4837 else 4838 return Defining_Entity (U); 4839 end if; 4840 end Entity_Of_Unit; 4841 4842 ---------------------- 4843 -- Find_Direct_Name -- 4844 ---------------------- 4845 4846 procedure Find_Direct_Name 4847 (N : Node_Id; 4848 Errors_OK : Boolean := True; 4849 Marker_OK : Boolean := True; 4850 Reference_OK : Boolean := True) 4851 is 4852 E : Entity_Id; 4853 E2 : Entity_Id; 4854 Msg : Boolean; 4855 4856 Homonyms : Entity_Id; 4857 -- Saves start of homonym chain 4858 4859 Inst : Entity_Id := Empty; 4860 -- Enclosing instance, if any 4861 4862 Nvis_Entity : Boolean; 4863 -- Set True to indicate that there is at least one entity on the homonym 4864 -- chain which, while not visible, is visible enough from the user point 4865 -- of view to warrant an error message of "not visible" rather than 4866 -- undefined. 4867 4868 Nvis_Is_Private_Subprg : Boolean := False; 4869 -- Ada 2005 (AI-262): Set True to indicate that a form of Beaujolais 4870 -- effect concerning library subprograms has been detected. Used to 4871 -- generate the precise error message. 4872 4873 function From_Actual_Package (E : Entity_Id) return Boolean; 4874 -- Returns true if the entity is an actual for a package that is itself 4875 -- an actual for a formal package of the current instance. Such an 4876 -- entity requires special handling because it may be use-visible but 4877 -- hides directly visible entities defined outside the instance, because 4878 -- the corresponding formal did so in the generic. 4879 4880 function Is_Actual_Parameter return Boolean; 4881 -- This function checks if the node N is an identifier that is an actual 4882 -- parameter of a procedure call. If so it returns True, otherwise it 4883 -- return False. The reason for this check is that at this stage we do 4884 -- not know what procedure is being called if the procedure might be 4885 -- overloaded, so it is premature to go setting referenced flags or 4886 -- making calls to Generate_Reference. We will wait till Resolve_Actuals 4887 -- for that processing 4888 4889 function Known_But_Invisible (E : Entity_Id) return Boolean; 4890 -- This function determines whether a reference to the entity E, which 4891 -- is not visible, can reasonably be considered to be known to the 4892 -- writer of the reference. This is a heuristic test, used only for 4893 -- the purposes of figuring out whether we prefer to complain that an 4894 -- entity is undefined or invisible (and identify the declaration of 4895 -- the invisible entity in the latter case). The point here is that we 4896 -- don't want to complain that something is invisible and then point to 4897 -- something entirely mysterious to the writer. 4898 4899 procedure Nvis_Messages; 4900 -- Called if there are no visible entries for N, but there is at least 4901 -- one non-directly visible, or hidden declaration. This procedure 4902 -- outputs an appropriate set of error messages. 4903 4904 procedure Undefined (Nvis : Boolean); 4905 -- This function is called if the current node has no corresponding 4906 -- visible entity or entities. The value set in Msg indicates whether 4907 -- an error message was generated (multiple error messages for the 4908 -- same variable are generally suppressed, see body for details). 4909 -- Msg is True if an error message was generated, False if not. This 4910 -- value is used by the caller to determine whether or not to output 4911 -- additional messages where appropriate. The parameter is set False 4912 -- to get the message "X is undefined", and True to get the message 4913 -- "X is not visible". 4914 4915 ------------------------- 4916 -- From_Actual_Package -- 4917 ------------------------- 4918 4919 function From_Actual_Package (E : Entity_Id) return Boolean is 4920 Scop : constant Entity_Id := Scope (E); 4921 -- Declared scope of candidate entity 4922 4923 function Declared_In_Actual (Pack : Entity_Id) return Boolean; 4924 -- Recursive function that does the work and examines actuals of 4925 -- actual packages of current instance. 4926 4927 ------------------------ 4928 -- Declared_In_Actual -- 4929 ------------------------ 4930 4931 function Declared_In_Actual (Pack : Entity_Id) return Boolean is 4932 Act : Entity_Id; 4933 4934 begin 4935 if No (Associated_Formal_Package (Pack)) then 4936 return False; 4937 4938 else 4939 Act := First_Entity (Pack); 4940 while Present (Act) loop 4941 if Renamed_Object (Pack) = Scop then 4942 return True; 4943 4944 -- Check for end of list of actuals 4945 4946 elsif Ekind (Act) = E_Package 4947 and then Renamed_Object (Act) = Pack 4948 then 4949 return False; 4950 4951 elsif Ekind (Act) = E_Package 4952 and then Declared_In_Actual (Act) 4953 then 4954 return True; 4955 end if; 4956 4957 Next_Entity (Act); 4958 end loop; 4959 4960 return False; 4961 end if; 4962 end Declared_In_Actual; 4963 4964 -- Local variables 4965 4966 Act : Entity_Id; 4967 4968 -- Start of processing for From_Actual_Package 4969 4970 begin 4971 if not In_Instance then 4972 return False; 4973 4974 else 4975 Inst := Current_Scope; 4976 while Present (Inst) 4977 and then Ekind (Inst) /= E_Package 4978 and then not Is_Generic_Instance (Inst) 4979 loop 4980 Inst := Scope (Inst); 4981 end loop; 4982 4983 if No (Inst) then 4984 return False; 4985 end if; 4986 4987 Act := First_Entity (Inst); 4988 while Present (Act) loop 4989 if Ekind (Act) = E_Package 4990 and then Declared_In_Actual (Act) 4991 then 4992 return True; 4993 end if; 4994 4995 Next_Entity (Act); 4996 end loop; 4997 4998 return False; 4999 end if; 5000 end From_Actual_Package; 5001 5002 ------------------------- 5003 -- Is_Actual_Parameter -- 5004 ------------------------- 5005 5006 function Is_Actual_Parameter return Boolean is 5007 begin 5008 return 5009 Nkind (N) = N_Identifier 5010 and then 5011 (Nkind (Parent (N)) = N_Procedure_Call_Statement 5012 or else 5013 (Nkind (Parent (N)) = N_Parameter_Association 5014 and then N = Explicit_Actual_Parameter (Parent (N)) 5015 and then Nkind (Parent (Parent (N))) = 5016 N_Procedure_Call_Statement)); 5017 end Is_Actual_Parameter; 5018 5019 ------------------------- 5020 -- Known_But_Invisible -- 5021 ------------------------- 5022 5023 function Known_But_Invisible (E : Entity_Id) return Boolean is 5024 Fname : File_Name_Type; 5025 5026 begin 5027 -- Entities in Standard are always considered to be known 5028 5029 if Sloc (E) <= Standard_Location then 5030 return True; 5031 5032 -- An entity that does not come from source is always considered 5033 -- to be unknown, since it is an artifact of code expansion. 5034 5035 elsif not Comes_From_Source (E) then 5036 return False; 5037 5038 -- In gnat internal mode, we consider all entities known. The 5039 -- historical reason behind this discrepancy is not known??? But the 5040 -- only effect is to modify the error message given, so it is not 5041 -- critical. Since it only affects the exact wording of error 5042 -- messages in illegal programs, we do not mention this as an 5043 -- effect of -gnatg, since it is not a language modification. 5044 5045 elsif GNAT_Mode then 5046 return True; 5047 end if; 5048 5049 -- Here we have an entity that is not from package Standard, and 5050 -- which comes from Source. See if it comes from an internal file. 5051 5052 Fname := Unit_File_Name (Get_Source_Unit (E)); 5053 5054 -- Case of from internal file 5055 5056 if In_Internal_Unit (E) then 5057 5058 -- Private part entities in internal files are never considered 5059 -- to be known to the writer of normal application code. 5060 5061 if Is_Hidden (E) then 5062 return False; 5063 end if; 5064 5065 -- Entities from System packages other than System and 5066 -- System.Storage_Elements are not considered to be known. 5067 -- System.Auxxxx files are also considered known to the user. 5068 5069 -- Should refine this at some point to generally distinguish 5070 -- between known and unknown internal files ??? 5071 5072 Get_Name_String (Fname); 5073 5074 return 5075 Name_Len < 2 5076 or else 5077 Name_Buffer (1 .. 2) /= "s-" 5078 or else 5079 Name_Buffer (3 .. 8) = "stoele" 5080 or else 5081 Name_Buffer (3 .. 5) = "aux"; 5082 5083 -- If not an internal file, then entity is definitely known, even if 5084 -- it is in a private part (the message generated will note that it 5085 -- is in a private part). 5086 5087 else 5088 return True; 5089 end if; 5090 end Known_But_Invisible; 5091 5092 ------------------- 5093 -- Nvis_Messages -- 5094 ------------------- 5095 5096 procedure Nvis_Messages is 5097 Comp_Unit : Node_Id; 5098 Ent : Entity_Id; 5099 Found : Boolean := False; 5100 Hidden : Boolean := False; 5101 Item : Node_Id; 5102 5103 begin 5104 if not Errors_OK then 5105 return; 5106 end if; 5107 5108 -- Ada 2005 (AI-262): Generate a precise error concerning the 5109 -- Beaujolais effect that was previously detected 5110 5111 if Nvis_Is_Private_Subprg then 5112 5113 pragma Assert (Nkind (E2) = N_Defining_Identifier 5114 and then Ekind (E2) = E_Function 5115 and then Scope (E2) = Standard_Standard 5116 and then Has_Private_With (E2)); 5117 5118 -- Find the sloc corresponding to the private with'ed unit 5119 5120 Comp_Unit := Cunit (Current_Sem_Unit); 5121 Error_Msg_Sloc := No_Location; 5122 5123 Item := First (Context_Items (Comp_Unit)); 5124 while Present (Item) loop 5125 if Nkind (Item) = N_With_Clause 5126 and then Private_Present (Item) 5127 and then Entity (Name (Item)) = E2 5128 then 5129 Error_Msg_Sloc := Sloc (Item); 5130 exit; 5131 end if; 5132 5133 Next (Item); 5134 end loop; 5135 5136 pragma Assert (Error_Msg_Sloc /= No_Location); 5137 5138 Error_Msg_N ("(Ada 2005): hidden by private with clause #", N); 5139 return; 5140 end if; 5141 5142 Undefined (Nvis => True); 5143 5144 if Msg then 5145 5146 -- First loop does hidden declarations 5147 5148 Ent := Homonyms; 5149 while Present (Ent) loop 5150 if Is_Potentially_Use_Visible (Ent) then 5151 if not Hidden then 5152 Error_Msg_N -- CODEFIX 5153 ("multiple use clauses cause hiding!", N); 5154 Hidden := True; 5155 end if; 5156 5157 Error_Msg_Sloc := Sloc (Ent); 5158 Error_Msg_N -- CODEFIX 5159 ("hidden declaration#!", N); 5160 end if; 5161 5162 Ent := Homonym (Ent); 5163 end loop; 5164 5165 -- If we found hidden declarations, then that's enough, don't 5166 -- bother looking for non-visible declarations as well. 5167 5168 if Hidden then 5169 return; 5170 end if; 5171 5172 -- Second loop does non-directly visible declarations 5173 5174 Ent := Homonyms; 5175 while Present (Ent) loop 5176 if not Is_Potentially_Use_Visible (Ent) then 5177 5178 -- Do not bother the user with unknown entities 5179 5180 if not Known_But_Invisible (Ent) then 5181 goto Continue; 5182 end if; 5183 5184 Error_Msg_Sloc := Sloc (Ent); 5185 5186 -- Output message noting that there is a non-visible 5187 -- declaration, distinguishing the private part case. 5188 5189 if Is_Hidden (Ent) then 5190 Error_Msg_N ("non-visible (private) declaration#!", N); 5191 5192 -- If the entity is declared in a generic package, it 5193 -- cannot be visible, so there is no point in adding it 5194 -- to the list of candidates if another homograph from a 5195 -- non-generic package has been seen. 5196 5197 elsif Ekind (Scope (Ent)) = E_Generic_Package 5198 and then Found 5199 then 5200 null; 5201 5202 else 5203 Error_Msg_N -- CODEFIX 5204 ("non-visible declaration#!", N); 5205 5206 if Ekind (Scope (Ent)) /= E_Generic_Package then 5207 Found := True; 5208 end if; 5209 5210 if Is_Compilation_Unit (Ent) 5211 and then 5212 Nkind (Parent (Parent (N))) = N_Use_Package_Clause 5213 then 5214 Error_Msg_Qual_Level := 99; 5215 Error_Msg_NE -- CODEFIX 5216 ("\\missing `WITH &;`", N, Ent); 5217 Error_Msg_Qual_Level := 0; 5218 end if; 5219 5220 if Ekind (Ent) = E_Discriminant 5221 and then Present (Corresponding_Discriminant (Ent)) 5222 and then Scope (Corresponding_Discriminant (Ent)) = 5223 Etype (Scope (Ent)) 5224 then 5225 Error_Msg_N 5226 ("inherited discriminant not allowed here" & 5227 " (RM 3.8 (12), 3.8.1 (6))!", N); 5228 end if; 5229 end if; 5230 5231 -- Set entity and its containing package as referenced. We 5232 -- can't be sure of this, but this seems a better choice 5233 -- to avoid unused entity messages. 5234 5235 if Comes_From_Source (Ent) then 5236 Set_Referenced (Ent); 5237 Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent))); 5238 end if; 5239 end if; 5240 5241 <<Continue>> 5242 Ent := Homonym (Ent); 5243 end loop; 5244 end if; 5245 end Nvis_Messages; 5246 5247 --------------- 5248 -- Undefined -- 5249 --------------- 5250 5251 procedure Undefined (Nvis : Boolean) is 5252 Emsg : Error_Msg_Id; 5253 5254 begin 5255 -- We should never find an undefined internal name. If we do, then 5256 -- see if we have previous errors. If so, ignore on the grounds that 5257 -- it is probably a cascaded message (e.g. a block label from a badly 5258 -- formed block). If no previous errors, then we have a real internal 5259 -- error of some kind so raise an exception. 5260 5261 if Is_Internal_Name (Chars (N)) then 5262 if Total_Errors_Detected /= 0 then 5263 return; 5264 else 5265 raise Program_Error; 5266 end if; 5267 end if; 5268 5269 -- A very specialized error check, if the undefined variable is 5270 -- a case tag, and the case type is an enumeration type, check 5271 -- for a possible misspelling, and if so, modify the identifier 5272 5273 -- Named aggregate should also be handled similarly ??? 5274 5275 if Errors_OK 5276 and then Nkind (N) = N_Identifier 5277 and then Nkind (Parent (N)) = N_Case_Statement_Alternative 5278 then 5279 declare 5280 Case_Stm : constant Node_Id := Parent (Parent (N)); 5281 Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); 5282 5283 Lit : Node_Id; 5284 5285 begin 5286 if Is_Enumeration_Type (Case_Typ) 5287 and then not Is_Standard_Character_Type (Case_Typ) 5288 then 5289 Lit := First_Literal (Case_Typ); 5290 Get_Name_String (Chars (Lit)); 5291 5292 if Chars (Lit) /= Chars (N) 5293 and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) 5294 then 5295 Error_Msg_Node_2 := Lit; 5296 Error_Msg_N -- CODEFIX 5297 ("& is undefined, assume misspelling of &", N); 5298 Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); 5299 return; 5300 end if; 5301 5302 Lit := Next_Literal (Lit); 5303 end if; 5304 end; 5305 end if; 5306 5307 -- Normal processing 5308 5309 Set_Entity (N, Any_Id); 5310 Set_Etype (N, Any_Type); 5311 5312 if Errors_OK then 5313 5314 -- We use the table Urefs to keep track of entities for which we 5315 -- have issued errors for undefined references. Multiple errors 5316 -- for a single name are normally suppressed, however we modify 5317 -- the error message to alert the programmer to this effect. 5318 5319 for J in Urefs.First .. Urefs.Last loop 5320 if Chars (N) = Chars (Urefs.Table (J).Node) then 5321 if Urefs.Table (J).Err /= No_Error_Msg 5322 and then Sloc (N) /= Urefs.Table (J).Loc 5323 then 5324 Error_Msg_Node_1 := Urefs.Table (J).Node; 5325 5326 if Urefs.Table (J).Nvis then 5327 Change_Error_Text (Urefs.Table (J).Err, 5328 "& is not visible (more references follow)"); 5329 else 5330 Change_Error_Text (Urefs.Table (J).Err, 5331 "& is undefined (more references follow)"); 5332 end if; 5333 5334 Urefs.Table (J).Err := No_Error_Msg; 5335 end if; 5336 5337 -- Although we will set Msg False, and thus suppress the 5338 -- message, we also set Error_Posted True, to avoid any 5339 -- cascaded messages resulting from the undefined reference. 5340 5341 Msg := False; 5342 Set_Error_Posted (N); 5343 return; 5344 end if; 5345 end loop; 5346 5347 -- If entry not found, this is first undefined occurrence 5348 5349 if Nvis then 5350 Error_Msg_N ("& is not visible!", N); 5351 Emsg := Get_Msg_Id; 5352 5353 else 5354 Error_Msg_N ("& is undefined!", N); 5355 Emsg := Get_Msg_Id; 5356 5357 -- A very bizarre special check, if the undefined identifier 5358 -- is Put or Put_Line, then add a special error message (since 5359 -- this is a very common error for beginners to make). 5360 5361 if Nam_In (Chars (N), Name_Put, Name_Put_Line) then 5362 Error_Msg_N -- CODEFIX 5363 ("\\possible missing `WITH Ada.Text_'I'O; " & 5364 "USE Ada.Text_'I'O`!", N); 5365 5366 -- Another special check if N is the prefix of a selected 5367 -- component which is a known unit: add message complaining 5368 -- about missing with for this unit. 5369 5370 elsif Nkind (Parent (N)) = N_Selected_Component 5371 and then N = Prefix (Parent (N)) 5372 and then Is_Known_Unit (Parent (N)) 5373 then 5374 Error_Msg_Node_2 := Selector_Name (Parent (N)); 5375 Error_Msg_N -- CODEFIX 5376 ("\\missing `WITH &.&;`", Prefix (Parent (N))); 5377 end if; 5378 5379 -- Now check for possible misspellings 5380 5381 declare 5382 E : Entity_Id; 5383 Ematch : Entity_Id := Empty; 5384 5385 Last_Name_Id : constant Name_Id := 5386 Name_Id (Nat (First_Name_Id) + 5387 Name_Entries_Count - 1); 5388 5389 begin 5390 for Nam in First_Name_Id .. Last_Name_Id loop 5391 E := Get_Name_Entity_Id (Nam); 5392 5393 if Present (E) 5394 and then (Is_Immediately_Visible (E) 5395 or else 5396 Is_Potentially_Use_Visible (E)) 5397 then 5398 if Is_Bad_Spelling_Of (Chars (N), Nam) then 5399 Ematch := E; 5400 exit; 5401 end if; 5402 end if; 5403 end loop; 5404 5405 if Present (Ematch) then 5406 Error_Msg_NE -- CODEFIX 5407 ("\possible misspelling of&", N, Ematch); 5408 end if; 5409 end; 5410 end if; 5411 5412 -- Make entry in undefined references table unless the full errors 5413 -- switch is set, in which case by refraining from generating the 5414 -- table entry we guarantee that we get an error message for every 5415 -- undefined reference. The entry is not added if we are ignoring 5416 -- errors. 5417 5418 if not All_Errors_Mode and then Ignore_Errors_Enable = 0 then 5419 Urefs.Append ( 5420 (Node => N, 5421 Err => Emsg, 5422 Nvis => Nvis, 5423 Loc => Sloc (N))); 5424 end if; 5425 5426 Msg := True; 5427 end if; 5428 end Undefined; 5429 5430 -- Local variables 5431 5432 Nested_Inst : Entity_Id := Empty; 5433 -- The entity of a nested instance which appears within Inst (if any) 5434 5435 -- Start of processing for Find_Direct_Name 5436 5437 begin 5438 -- If the entity pointer is already set, this is an internal node, or 5439 -- a node that is analyzed more than once, after a tree modification. 5440 -- In such a case there is no resolution to perform, just set the type. 5441 5442 if Present (Entity (N)) then 5443 if Is_Type (Entity (N)) then 5444 Set_Etype (N, Entity (N)); 5445 5446 else 5447 declare 5448 Entyp : constant Entity_Id := Etype (Entity (N)); 5449 5450 begin 5451 -- One special case here. If the Etype field is already set, 5452 -- and references the packed array type corresponding to the 5453 -- etype of the referenced entity, then leave it alone. This 5454 -- happens for trees generated from Exp_Pakd, where expressions 5455 -- can be deliberately "mis-typed" to the packed array type. 5456 5457 if Is_Array_Type (Entyp) 5458 and then Is_Packed (Entyp) 5459 and then Present (Etype (N)) 5460 and then Etype (N) = Packed_Array_Impl_Type (Entyp) 5461 then 5462 null; 5463 5464 -- If not that special case, then just reset the Etype 5465 5466 else 5467 Set_Etype (N, Etype (Entity (N))); 5468 end if; 5469 end; 5470 end if; 5471 5472 -- Although the marking of use clauses happens at the end of 5473 -- Find_Direct_Name, a certain case where a generic actual satisfies 5474 -- a use clause must be checked here due to how the generic machinery 5475 -- handles the analysis of said actuals. 5476 5477 if In_Instance 5478 and then Nkind (Parent (N)) = N_Generic_Association 5479 then 5480 Mark_Use_Clauses (Entity (N)); 5481 end if; 5482 5483 return; 5484 end if; 5485 5486 -- Preserve relevant elaboration-related attributes of the context which 5487 -- are no longer available or very expensive to recompute once analysis, 5488 -- resolution, and expansion are over. 5489 5490 if Nkind (N) = N_Identifier then 5491 Mark_Elaboration_Attributes 5492 (N_Id => N, 5493 Modes => True); 5494 end if; 5495 5496 -- Here if Entity pointer was not set, we need full visibility analysis 5497 -- First we generate debugging output if the debug E flag is set. 5498 5499 if Debug_Flag_E then 5500 Write_Str ("Looking for "); 5501 Write_Name (Chars (N)); 5502 Write_Eol; 5503 end if; 5504 5505 Homonyms := Current_Entity (N); 5506 Nvis_Entity := False; 5507 5508 E := Homonyms; 5509 while Present (E) loop 5510 5511 -- If entity is immediately visible or potentially use visible, then 5512 -- process the entity and we are done. 5513 5514 if Is_Immediately_Visible (E) then 5515 goto Immediately_Visible_Entity; 5516 5517 elsif Is_Potentially_Use_Visible (E) then 5518 goto Potentially_Use_Visible_Entity; 5519 5520 -- Note if a known but invisible entity encountered 5521 5522 elsif Known_But_Invisible (E) then 5523 Nvis_Entity := True; 5524 end if; 5525 5526 -- Move to next entity in chain and continue search 5527 5528 E := Homonym (E); 5529 end loop; 5530 5531 -- If no entries on homonym chain that were potentially visible, 5532 -- and no entities reasonably considered as non-visible, then 5533 -- we have a plain undefined reference, with no additional 5534 -- explanation required. 5535 5536 if not Nvis_Entity then 5537 Undefined (Nvis => False); 5538 5539 -- Otherwise there is at least one entry on the homonym chain that 5540 -- is reasonably considered as being known and non-visible. 5541 5542 else 5543 Nvis_Messages; 5544 end if; 5545 5546 goto Done; 5547 5548 -- Processing for a potentially use visible entry found. We must search 5549 -- the rest of the homonym chain for two reasons. First, if there is a 5550 -- directly visible entry, then none of the potentially use-visible 5551 -- entities are directly visible (RM 8.4(10)). Second, we need to check 5552 -- for the case of multiple potentially use-visible entries hiding one 5553 -- another and as a result being non-directly visible (RM 8.4(11)). 5554 5555 <<Potentially_Use_Visible_Entity>> declare 5556 Only_One_Visible : Boolean := True; 5557 All_Overloadable : Boolean := Is_Overloadable (E); 5558 5559 begin 5560 E2 := Homonym (E); 5561 while Present (E2) loop 5562 if Is_Immediately_Visible (E2) then 5563 5564 -- If the use-visible entity comes from the actual for a 5565 -- formal package, it hides a directly visible entity from 5566 -- outside the instance. 5567 5568 if From_Actual_Package (E) 5569 and then Scope_Depth (E2) < Scope_Depth (Inst) 5570 then 5571 goto Found; 5572 else 5573 E := E2; 5574 goto Immediately_Visible_Entity; 5575 end if; 5576 5577 elsif Is_Potentially_Use_Visible (E2) then 5578 Only_One_Visible := False; 5579 All_Overloadable := All_Overloadable and Is_Overloadable (E2); 5580 5581 -- Ada 2005 (AI-262): Protect against a form of Beaujolais effect 5582 -- that can occur in private_with clauses. Example: 5583 5584 -- with A; 5585 -- private with B; package A is 5586 -- package C is function B return Integer; 5587 -- use A; end A; 5588 -- V1 : Integer := B; 5589 -- private function B return Integer; 5590 -- V2 : Integer := B; 5591 -- end C; 5592 5593 -- V1 resolves to A.B, but V2 resolves to library unit B 5594 5595 elsif Ekind (E2) = E_Function 5596 and then Scope (E2) = Standard_Standard 5597 and then Has_Private_With (E2) 5598 then 5599 Only_One_Visible := False; 5600 All_Overloadable := False; 5601 Nvis_Is_Private_Subprg := True; 5602 exit; 5603 end if; 5604 5605 E2 := Homonym (E2); 5606 end loop; 5607 5608 -- On falling through this loop, we have checked that there are no 5609 -- immediately visible entities. Only_One_Visible is set if exactly 5610 -- one potentially use visible entity exists. All_Overloadable is 5611 -- set if all the potentially use visible entities are overloadable. 5612 -- The condition for legality is that either there is one potentially 5613 -- use visible entity, or if there is more than one, then all of them 5614 -- are overloadable. 5615 5616 if Only_One_Visible or All_Overloadable then 5617 goto Found; 5618 5619 -- If there is more than one potentially use-visible entity and at 5620 -- least one of them non-overloadable, we have an error (RM 8.4(11)). 5621 -- Note that E points to the first such entity on the homonym list. 5622 5623 else 5624 -- If one of the entities is declared in an actual package, it 5625 -- was visible in the generic, and takes precedence over other 5626 -- entities that are potentially use-visible. The same applies 5627 -- if the entity is declared in a local instantiation of the 5628 -- current instance. 5629 5630 if In_Instance then 5631 5632 -- Find the current instance 5633 5634 Inst := Current_Scope; 5635 while Present (Inst) and then Inst /= Standard_Standard loop 5636 if Is_Generic_Instance (Inst) then 5637 exit; 5638 end if; 5639 5640 Inst := Scope (Inst); 5641 end loop; 5642 5643 -- Reexamine the candidate entities, giving priority to those 5644 -- that were visible within the generic. 5645 5646 E2 := E; 5647 while Present (E2) loop 5648 Nested_Inst := Nearest_Enclosing_Instance (E2); 5649 5650 -- The entity is declared within an actual package, or in a 5651 -- nested instance. The ">=" accounts for the case where the 5652 -- current instance and the nested instance are the same. 5653 5654 if From_Actual_Package (E2) 5655 or else (Present (Nested_Inst) 5656 and then Scope_Depth (Nested_Inst) >= 5657 Scope_Depth (Inst)) 5658 then 5659 E := E2; 5660 goto Found; 5661 end if; 5662 5663 E2 := Homonym (E2); 5664 end loop; 5665 5666 Nvis_Messages; 5667 goto Done; 5668 5669 elsif Is_Predefined_Unit (Current_Sem_Unit) then 5670 -- A use clause in the body of a system file creates conflict 5671 -- with some entity in a user scope, while rtsfind is active. 5672 -- Keep only the entity coming from another predefined unit. 5673 5674 E2 := E; 5675 while Present (E2) loop 5676 if In_Predefined_Unit (E2) then 5677 E := E2; 5678 goto Found; 5679 end if; 5680 5681 E2 := Homonym (E2); 5682 end loop; 5683 5684 -- Entity must exist because predefined unit is correct 5685 5686 raise Program_Error; 5687 5688 else 5689 Nvis_Messages; 5690 goto Done; 5691 end if; 5692 end if; 5693 end; 5694 5695 -- Come here with E set to the first immediately visible entity on 5696 -- the homonym chain. This is the one we want unless there is another 5697 -- immediately visible entity further on in the chain for an inner 5698 -- scope (RM 8.3(8)). 5699 5700 <<Immediately_Visible_Entity>> declare 5701 Level : Int; 5702 Scop : Entity_Id; 5703 5704 begin 5705 -- Find scope level of initial entity. When compiling through 5706 -- Rtsfind, the previous context is not completely invisible, and 5707 -- an outer entity may appear on the chain, whose scope is below 5708 -- the entry for Standard that delimits the current scope stack. 5709 -- Indicate that the level for this spurious entry is outside of 5710 -- the current scope stack. 5711 5712 Level := Scope_Stack.Last; 5713 loop 5714 Scop := Scope_Stack.Table (Level).Entity; 5715 exit when Scop = Scope (E); 5716 Level := Level - 1; 5717 exit when Scop = Standard_Standard; 5718 end loop; 5719 5720 -- Now search remainder of homonym chain for more inner entry 5721 -- If the entity is Standard itself, it has no scope, and we 5722 -- compare it with the stack entry directly. 5723 5724 E2 := Homonym (E); 5725 while Present (E2) loop 5726 if Is_Immediately_Visible (E2) then 5727 5728 -- If a generic package contains a local declaration that 5729 -- has the same name as the generic, there may be a visibility 5730 -- conflict in an instance, where the local declaration must 5731 -- also hide the name of the corresponding package renaming. 5732 -- We check explicitly for a package declared by a renaming, 5733 -- whose renamed entity is an instance that is on the scope 5734 -- stack, and that contains a homonym in the same scope. Once 5735 -- we have found it, we know that the package renaming is not 5736 -- immediately visible, and that the identifier denotes the 5737 -- other entity (and its homonyms if overloaded). 5738 5739 if Scope (E) = Scope (E2) 5740 and then Ekind (E) = E_Package 5741 and then Present (Renamed_Object (E)) 5742 and then Is_Generic_Instance (Renamed_Object (E)) 5743 and then In_Open_Scopes (Renamed_Object (E)) 5744 and then Comes_From_Source (N) 5745 then 5746 Set_Is_Immediately_Visible (E, False); 5747 E := E2; 5748 5749 else 5750 for J in Level + 1 .. Scope_Stack.Last loop 5751 if Scope_Stack.Table (J).Entity = Scope (E2) 5752 or else Scope_Stack.Table (J).Entity = E2 5753 then 5754 Level := J; 5755 E := E2; 5756 exit; 5757 end if; 5758 end loop; 5759 end if; 5760 end if; 5761 5762 E2 := Homonym (E2); 5763 end loop; 5764 5765 -- At the end of that loop, E is the innermost immediately 5766 -- visible entity, so we are all set. 5767 end; 5768 5769 -- Come here with entity found, and stored in E 5770 5771 <<Found>> begin 5772 5773 -- Check violation of No_Wide_Characters restriction 5774 5775 Check_Wide_Character_Restriction (E, N); 5776 5777 -- When distribution features are available (Get_PCS_Name /= 5778 -- Name_No_DSA), a remote access-to-subprogram type is converted 5779 -- into a record type holding whatever information is needed to 5780 -- perform a remote call on an RCI subprogram. In that case we 5781 -- rewrite any occurrence of the RAS type into the equivalent record 5782 -- type here. 'Access attribute references and RAS dereferences are 5783 -- then implemented using specific TSSs. However when distribution is 5784 -- not available (case of Get_PCS_Name = Name_No_DSA), we bypass the 5785 -- generation of these TSSs, and we must keep the RAS type in its 5786 -- original access-to-subprogram form (since all calls through a 5787 -- value of such type will be local anyway in the absence of a PCS). 5788 5789 if Comes_From_Source (N) 5790 and then Is_Remote_Access_To_Subprogram_Type (E) 5791 and then Ekind (E) = E_Access_Subprogram_Type 5792 and then Expander_Active 5793 and then Get_PCS_Name /= Name_No_DSA 5794 then 5795 Rewrite (N, New_Occurrence_Of (Equivalent_Type (E), Sloc (N))); 5796 goto Done; 5797 end if; 5798 5799 -- Set the entity. Note that the reason we call Set_Entity for the 5800 -- overloadable case, as opposed to Set_Entity_With_Checks is 5801 -- that in the overloaded case, the initial call can set the wrong 5802 -- homonym. The call that sets the right homonym is in Sem_Res and 5803 -- that call does use Set_Entity_With_Checks, so we don't miss 5804 -- a style check. 5805 5806 if Is_Overloadable (E) then 5807 Set_Entity (N, E); 5808 else 5809 Set_Entity_With_Checks (N, E); 5810 end if; 5811 5812 if Is_Type (E) then 5813 Set_Etype (N, E); 5814 else 5815 Set_Etype (N, Get_Full_View (Etype (E))); 5816 end if; 5817 5818 if Debug_Flag_E then 5819 Write_Str (" found "); 5820 Write_Entity_Info (E, " "); 5821 end if; 5822 5823 -- If the Ekind of the entity is Void, it means that all homonyms 5824 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this 5825 -- test is skipped if the current scope is a record and the name is 5826 -- a pragma argument expression (case of Atomic and Volatile pragmas 5827 -- and possibly other similar pragmas added later, which are allowed 5828 -- to reference components in the current record). 5829 5830 if Ekind (E) = E_Void 5831 and then 5832 (not Is_Record_Type (Current_Scope) 5833 or else Nkind (Parent (N)) /= N_Pragma_Argument_Association) 5834 then 5835 Premature_Usage (N); 5836 5837 -- If the entity is overloadable, collect all interpretations of the 5838 -- name for subsequent overload resolution. We optimize a bit here to 5839 -- do this only if we have an overloadable entity that is not on its 5840 -- own on the homonym chain. 5841 5842 elsif Is_Overloadable (E) 5843 and then (Present (Homonym (E)) or else Current_Entity (N) /= E) 5844 then 5845 Collect_Interps (N); 5846 5847 -- If no homonyms were visible, the entity is unambiguous 5848 5849 if not Is_Overloaded (N) then 5850 if Reference_OK and then not Is_Actual_Parameter then 5851 Generate_Reference (E, N); 5852 end if; 5853 end if; 5854 5855 -- Case of non-overloadable entity, set the entity providing that 5856 -- we do not have the case of a discriminant reference within a 5857 -- default expression. Such references are replaced with the 5858 -- corresponding discriminal, which is the formal corresponding to 5859 -- to the discriminant in the initialization procedure. 5860 5861 else 5862 -- Entity is unambiguous, indicate that it is referenced here 5863 5864 -- For a renaming of an object, always generate simple reference, 5865 -- we don't try to keep track of assignments in this case, except 5866 -- in SPARK mode where renamings are traversed for generating 5867 -- local effects of subprograms. 5868 5869 if Reference_OK 5870 and then Is_Object (E) 5871 and then Present (Renamed_Object (E)) 5872 and then not GNATprove_Mode 5873 then 5874 Generate_Reference (E, N); 5875 5876 -- If the renamed entity is a private protected component, 5877 -- reference the original component as well. This needs to be 5878 -- done because the private renamings are installed before any 5879 -- analysis has occurred. Reference to a private component will 5880 -- resolve to the renaming and the original component will be 5881 -- left unreferenced, hence the following. 5882 5883 if Is_Prival (E) then 5884 Generate_Reference (Prival_Link (E), N); 5885 end if; 5886 5887 -- One odd case is that we do not want to set the Referenced flag 5888 -- if the entity is a label, and the identifier is the label in 5889 -- the source, since this is not a reference from the point of 5890 -- view of the user. 5891 5892 elsif Nkind (Parent (N)) = N_Label then 5893 declare 5894 R : constant Boolean := Referenced (E); 5895 5896 begin 5897 -- Generate reference unless this is an actual parameter 5898 -- (see comment below) 5899 5900 if Reference_OK and then Is_Actual_Parameter then 5901 Generate_Reference (E, N); 5902 Set_Referenced (E, R); 5903 end if; 5904 end; 5905 5906 -- Normal case, not a label: generate reference 5907 5908 else 5909 if Reference_OK and then not Is_Actual_Parameter then 5910 5911 -- Package or generic package is always a simple reference 5912 5913 if Ekind_In (E, E_Package, E_Generic_Package) then 5914 Generate_Reference (E, N, 'r'); 5915 5916 -- Else see if we have a left hand side 5917 5918 else 5919 case Is_LHS (N) is 5920 when Yes => 5921 Generate_Reference (E, N, 'm'); 5922 5923 when No => 5924 Generate_Reference (E, N, 'r'); 5925 5926 -- If we don't know now, generate reference later 5927 5928 when Unknown => 5929 Deferred_References.Append ((E, N)); 5930 end case; 5931 end if; 5932 end if; 5933 end if; 5934 5935 Set_Entity_Or_Discriminal (N, E); 5936 5937 -- The name may designate a generalized reference, in which case 5938 -- the dereference interpretation will be included. Context is 5939 -- one in which a name is legal. 5940 5941 if Ada_Version >= Ada_2012 5942 and then 5943 (Nkind (Parent (N)) in N_Subexpr 5944 or else Nkind_In (Parent (N), N_Assignment_Statement, 5945 N_Object_Declaration, 5946 N_Parameter_Association)) 5947 then 5948 Check_Implicit_Dereference (N, Etype (E)); 5949 end if; 5950 end if; 5951 end; 5952 5953 -- Mark relevant use-type and use-package clauses as effective if the 5954 -- node in question is not overloaded and therefore does not require 5955 -- resolution. 5956 -- 5957 -- Note: Generic actual subprograms do not follow the normal resolution 5958 -- path, so ignore the fact that they are overloaded and mark them 5959 -- anyway. 5960 5961 if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then 5962 Mark_Use_Clauses (N); 5963 end if; 5964 5965 -- Come here with entity set 5966 5967 <<Done>> 5968 Check_Restriction_No_Use_Of_Entity (N); 5969 5970 -- Annotate the tree by creating a variable reference marker in case the 5971 -- original variable reference is folded or optimized away. The variable 5972 -- reference marker is automatically saved for later examination by the 5973 -- ABE Processing phase. Variable references which act as actuals in a 5974 -- call require special processing and are left to Resolve_Actuals. The 5975 -- reference is a write when it appears on the left hand side of an 5976 -- assignment. 5977 5978 if Marker_OK 5979 and then Needs_Variable_Reference_Marker 5980 (N => N, 5981 Calls_OK => False) 5982 then 5983 declare 5984 Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; 5985 5986 begin 5987 Build_Variable_Reference_Marker 5988 (N => N, 5989 Read => not Is_Assignment_LHS, 5990 Write => Is_Assignment_LHS); 5991 end; 5992 end if; 5993 end Find_Direct_Name; 5994 5995 ------------------------ 5996 -- Find_Expanded_Name -- 5997 ------------------------ 5998 5999 -- This routine searches the homonym chain of the entity until it finds 6000 -- an entity declared in the scope denoted by the prefix. If the entity 6001 -- is private, it may nevertheless be immediately visible, if we are in 6002 -- the scope of its declaration. 6003 6004 procedure Find_Expanded_Name (N : Node_Id) is 6005 function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean; 6006 -- Determine whether expanded name Nod appears within a pragma which is 6007 -- a suitable context for an abstract view of a state or variable. The 6008 -- following pragmas fall in this category: 6009 -- Depends 6010 -- Global 6011 -- Initializes 6012 -- Refined_Depends 6013 -- Refined_Global 6014 -- 6015 -- In addition, pragma Abstract_State is also considered suitable even 6016 -- though it is an illegal context for an abstract view as this allows 6017 -- for proper resolution of abstract views of variables. This illegal 6018 -- context is later flagged in the analysis of indicator Part_Of. 6019 6020 ----------------------------- 6021 -- In_Abstract_View_Pragma -- 6022 ----------------------------- 6023 6024 function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean is 6025 Par : Node_Id; 6026 6027 begin 6028 -- Climb the parent chain looking for a pragma 6029 6030 Par := Nod; 6031 while Present (Par) loop 6032 if Nkind (Par) = N_Pragma then 6033 if Nam_In (Pragma_Name_Unmapped (Par), 6034 Name_Abstract_State, 6035 Name_Depends, 6036 Name_Global, 6037 Name_Initializes, 6038 Name_Refined_Depends, 6039 Name_Refined_Global) 6040 then 6041 return True; 6042 6043 -- Otherwise the pragma is not a legal context for an abstract 6044 -- view. 6045 6046 else 6047 exit; 6048 end if; 6049 6050 -- Prevent the search from going too far 6051 6052 elsif Is_Body_Or_Package_Declaration (Par) then 6053 exit; 6054 end if; 6055 6056 Par := Parent (Par); 6057 end loop; 6058 6059 return False; 6060 end In_Abstract_View_Pragma; 6061 6062 -- Local variables 6063 6064 Selector : constant Node_Id := Selector_Name (N); 6065 6066 Candidate : Entity_Id := Empty; 6067 P_Name : Entity_Id; 6068 Id : Entity_Id; 6069 6070 -- Start of processing for Find_Expanded_Name 6071 6072 begin 6073 P_Name := Entity (Prefix (N)); 6074 6075 -- If the prefix is a renamed package, look for the entity in the 6076 -- original package. 6077 6078 if Ekind (P_Name) = E_Package 6079 and then Present (Renamed_Object (P_Name)) 6080 then 6081 P_Name := Renamed_Object (P_Name); 6082 6083 -- Rewrite node with entity field pointing to renamed object 6084 6085 Rewrite (Prefix (N), New_Copy (Prefix (N))); 6086 Set_Entity (Prefix (N), P_Name); 6087 6088 -- If the prefix is an object of a concurrent type, look for 6089 -- the entity in the associated task or protected type. 6090 6091 elsif Is_Concurrent_Type (Etype (P_Name)) then 6092 P_Name := Etype (P_Name); 6093 end if; 6094 6095 Id := Current_Entity (Selector); 6096 6097 declare 6098 Is_New_Candidate : Boolean; 6099 6100 begin 6101 while Present (Id) loop 6102 if Scope (Id) = P_Name then 6103 Candidate := Id; 6104 Is_New_Candidate := True; 6105 6106 -- Handle abstract views of states and variables. These are 6107 -- acceptable candidates only when the reference to the view 6108 -- appears in certain pragmas. 6109 6110 if Ekind (Id) = E_Abstract_State 6111 and then From_Limited_With (Id) 6112 and then Present (Non_Limited_View (Id)) 6113 then 6114 if In_Abstract_View_Pragma (N) then 6115 Candidate := Non_Limited_View (Id); 6116 Is_New_Candidate := True; 6117 6118 -- Hide the candidate because it is not used in a proper 6119 -- context. 6120 6121 else 6122 Candidate := Empty; 6123 Is_New_Candidate := False; 6124 end if; 6125 end if; 6126 6127 -- Ada 2005 (AI-217): Handle shadow entities associated with 6128 -- types declared in limited-withed nested packages. We don't need 6129 -- to handle E_Incomplete_Subtype entities because the entities 6130 -- in the limited view are always E_Incomplete_Type and 6131 -- E_Class_Wide_Type entities (see Build_Limited_Views). 6132 6133 -- Regarding the expression used to evaluate the scope, it 6134 -- is important to note that the limited view also has shadow 6135 -- entities associated nested packages. For this reason the 6136 -- correct scope of the entity is the scope of the real entity. 6137 -- The non-limited view may itself be incomplete, in which case 6138 -- get the full view if available. 6139 6140 elsif Ekind_In (Id, E_Incomplete_Type, E_Class_Wide_Type) 6141 and then From_Limited_With (Id) 6142 and then Present (Non_Limited_View (Id)) 6143 and then Scope (Non_Limited_View (Id)) = P_Name 6144 then 6145 Candidate := Get_Full_View (Non_Limited_View (Id)); 6146 Is_New_Candidate := True; 6147 6148 -- An unusual case arises with a fully qualified name for an 6149 -- entity local to a generic child unit package, within an 6150 -- instantiation of that package. The name of the unit now 6151 -- denotes the renaming created within the instance. This is 6152 -- only relevant in an instance body, see below. 6153 6154 elsif Is_Generic_Instance (Scope (Id)) 6155 and then In_Open_Scopes (Scope (Id)) 6156 and then In_Instance_Body 6157 and then Ekind (Scope (Id)) = E_Package 6158 and then Ekind (Id) = E_Package 6159 and then Renamed_Entity (Id) = Scope (Id) 6160 and then Is_Immediately_Visible (P_Name) 6161 then 6162 Is_New_Candidate := True; 6163 6164 else 6165 Is_New_Candidate := False; 6166 end if; 6167 6168 if Is_New_Candidate then 6169 6170 -- If entity is a child unit, either it is a visible child of 6171 -- the prefix, or we are in the body of a generic prefix, as 6172 -- will happen when a child unit is instantiated in the body 6173 -- of a generic parent. This is because the instance body does 6174 -- not restore the full compilation context, given that all 6175 -- non-local references have been captured. 6176 6177 if Is_Child_Unit (Id) or else P_Name = Standard_Standard then 6178 exit when Is_Visible_Lib_Unit (Id) 6179 or else (Is_Child_Unit (Id) 6180 and then In_Open_Scopes (Scope (Id)) 6181 and then In_Instance_Body); 6182 else 6183 exit when not Is_Hidden (Id); 6184 end if; 6185 6186 exit when Is_Immediately_Visible (Id); 6187 end if; 6188 6189 Id := Homonym (Id); 6190 end loop; 6191 end; 6192 6193 if No (Id) 6194 and then Ekind_In (P_Name, E_Procedure, E_Function) 6195 and then Is_Generic_Instance (P_Name) 6196 then 6197 -- Expanded name denotes entity in (instance of) generic subprogram. 6198 -- The entity may be in the subprogram instance, or may denote one of 6199 -- the formals, which is declared in the enclosing wrapper package. 6200 6201 P_Name := Scope (P_Name); 6202 6203 Id := Current_Entity (Selector); 6204 while Present (Id) loop 6205 exit when Scope (Id) = P_Name; 6206 Id := Homonym (Id); 6207 end loop; 6208 end if; 6209 6210 if No (Id) or else Chars (Id) /= Chars (Selector) then 6211 Set_Etype (N, Any_Type); 6212 6213 -- If we are looking for an entity defined in System, try to find it 6214 -- in the child package that may have been provided as an extension 6215 -- to System. The Extend_System pragma will have supplied the name of 6216 -- the extension, which may have to be loaded. 6217 6218 if Chars (P_Name) = Name_System 6219 and then Scope (P_Name) = Standard_Standard 6220 and then Present (System_Extend_Unit) 6221 and then Present_System_Aux (N) 6222 then 6223 Set_Entity (Prefix (N), System_Aux_Id); 6224 Find_Expanded_Name (N); 6225 return; 6226 6227 -- There is an implicit instance of the predefined operator in 6228 -- the given scope. The operator entity is defined in Standard. 6229 -- Has_Implicit_Operator makes the node into an Expanded_Name. 6230 6231 elsif Nkind (Selector) = N_Operator_Symbol 6232 and then Has_Implicit_Operator (N) 6233 then 6234 return; 6235 6236 -- If there is no literal defined in the scope denoted by the 6237 -- prefix, the literal may belong to (a type derived from) 6238 -- Standard_Character, for which we have no explicit literals. 6239 6240 elsif Nkind (Selector) = N_Character_Literal 6241 and then Has_Implicit_Character_Literal (N) 6242 then 6243 return; 6244 6245 else 6246 -- If the prefix is a single concurrent object, use its name in 6247 -- the error message, rather than that of the anonymous type. 6248 6249 if Is_Concurrent_Type (P_Name) 6250 and then Is_Internal_Name (Chars (P_Name)) 6251 then 6252 Error_Msg_Node_2 := Entity (Prefix (N)); 6253 else 6254 Error_Msg_Node_2 := P_Name; 6255 end if; 6256 6257 if P_Name = System_Aux_Id then 6258 P_Name := Scope (P_Name); 6259 Set_Entity (Prefix (N), P_Name); 6260 end if; 6261 6262 if Present (Candidate) then 6263 6264 -- If we know that the unit is a child unit we can give a more 6265 -- accurate error message. 6266 6267 if Is_Child_Unit (Candidate) then 6268 6269 -- If the candidate is a private child unit and we are in 6270 -- the visible part of a public unit, specialize the error 6271 -- message. There might be a private with_clause for it, 6272 -- but it is not currently active. 6273 6274 if Is_Private_Descendant (Candidate) 6275 and then Ekind (Current_Scope) = E_Package 6276 and then not In_Private_Part (Current_Scope) 6277 and then not Is_Private_Descendant (Current_Scope) 6278 then 6279 Error_Msg_N 6280 ("private child unit& is not visible here", Selector); 6281 6282 -- Normal case where we have a missing with for a child unit 6283 6284 else 6285 Error_Msg_Qual_Level := 99; 6286 Error_Msg_NE -- CODEFIX 6287 ("missing `WITH &;`", Selector, Candidate); 6288 Error_Msg_Qual_Level := 0; 6289 end if; 6290 6291 -- Here we don't know that this is a child unit 6292 6293 else 6294 Error_Msg_NE ("& is not a visible entity of&", N, Selector); 6295 end if; 6296 6297 else 6298 -- Within the instantiation of a child unit, the prefix may 6299 -- denote the parent instance, but the selector has the name 6300 -- of the original child. That is to say, when A.B appears 6301 -- within an instantiation of generic child unit B, the scope 6302 -- stack includes an instance of A (P_Name) and an instance 6303 -- of B under some other name. We scan the scope to find this 6304 -- child instance, which is the desired entity. 6305 -- Note that the parent may itself be a child instance, if 6306 -- the reference is of the form A.B.C, in which case A.B has 6307 -- already been rewritten with the proper entity. 6308 6309 if In_Open_Scopes (P_Name) 6310 and then Is_Generic_Instance (P_Name) 6311 then 6312 declare 6313 Gen_Par : constant Entity_Id := 6314 Generic_Parent (Specification 6315 (Unit_Declaration_Node (P_Name))); 6316 S : Entity_Id := Current_Scope; 6317 P : Entity_Id; 6318 6319 begin 6320 for J in reverse 0 .. Scope_Stack.Last loop 6321 S := Scope_Stack.Table (J).Entity; 6322 6323 exit when S = Standard_Standard; 6324 6325 if Ekind_In (S, E_Function, 6326 E_Package, 6327 E_Procedure) 6328 then 6329 P := 6330 Generic_Parent (Specification 6331 (Unit_Declaration_Node (S))); 6332 6333 -- Check that P is a generic child of the generic 6334 -- parent of the prefix. 6335 6336 if Present (P) 6337 and then Chars (P) = Chars (Selector) 6338 and then Scope (P) = Gen_Par 6339 then 6340 Id := S; 6341 goto Found; 6342 end if; 6343 end if; 6344 6345 end loop; 6346 end; 6347 end if; 6348 6349 -- If this is a selection from Ada, System or Interfaces, then 6350 -- we assume a missing with for the corresponding package. 6351 6352 if Is_Known_Unit (N) 6353 and then not (Present (Entity (Prefix (N))) 6354 and then Scope (Entity (Prefix (N))) /= 6355 Standard_Standard) 6356 then 6357 if not Error_Posted (N) then 6358 Error_Msg_Node_2 := Selector; 6359 Error_Msg_N -- CODEFIX 6360 ("missing `WITH &.&;`", Prefix (N)); 6361 end if; 6362 6363 -- If this is a selection from a dummy package, then suppress 6364 -- the error message, of course the entity is missing if the 6365 -- package is missing. 6366 6367 elsif Sloc (Error_Msg_Node_2) = No_Location then 6368 null; 6369 6370 -- Here we have the case of an undefined component 6371 6372 else 6373 -- The prefix may hide a homonym in the context that 6374 -- declares the desired entity. This error can use a 6375 -- specialized message. 6376 6377 if In_Open_Scopes (P_Name) then 6378 declare 6379 H : constant Entity_Id := Homonym (P_Name); 6380 6381 begin 6382 if Present (H) 6383 and then Is_Compilation_Unit (H) 6384 and then 6385 (Is_Immediately_Visible (H) 6386 or else Is_Visible_Lib_Unit (H)) 6387 then 6388 Id := First_Entity (H); 6389 while Present (Id) loop 6390 if Chars (Id) = Chars (Selector) then 6391 Error_Msg_Qual_Level := 99; 6392 Error_Msg_Name_1 := Chars (Selector); 6393 Error_Msg_NE 6394 ("% not declared in&", N, P_Name); 6395 Error_Msg_NE 6396 ("\use fully qualified name starting with " 6397 & "Standard to make& visible", N, H); 6398 Error_Msg_Qual_Level := 0; 6399 goto Done; 6400 end if; 6401 6402 Next_Entity (Id); 6403 end loop; 6404 end if; 6405 6406 -- If not found, standard error message 6407 6408 Error_Msg_NE ("& not declared in&", N, Selector); 6409 6410 <<Done>> null; 6411 end; 6412 6413 else 6414 -- Might be worth specializing the case when the prefix 6415 -- is a limited view. 6416 -- ... not declared in limited view of... 6417 6418 Error_Msg_NE ("& not declared in&", N, Selector); 6419 end if; 6420 6421 -- Check for misspelling of some entity in prefix 6422 6423 Id := First_Entity (P_Name); 6424 while Present (Id) loop 6425 if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector)) 6426 and then not Is_Internal_Name (Chars (Id)) 6427 then 6428 Error_Msg_NE -- CODEFIX 6429 ("possible misspelling of&", Selector, Id); 6430 exit; 6431 end if; 6432 6433 Next_Entity (Id); 6434 end loop; 6435 6436 -- Specialize the message if this may be an instantiation 6437 -- of a child unit that was not mentioned in the context. 6438 6439 if Nkind (Parent (N)) = N_Package_Instantiation 6440 and then Is_Generic_Instance (Entity (Prefix (N))) 6441 and then Is_Compilation_Unit 6442 (Generic_Parent (Parent (Entity (Prefix (N))))) 6443 then 6444 Error_Msg_Node_2 := Selector; 6445 Error_Msg_N -- CODEFIX 6446 ("\missing `WITH &.&;`", Prefix (N)); 6447 end if; 6448 end if; 6449 end if; 6450 6451 Id := Any_Id; 6452 end if; 6453 end if; 6454 6455 <<Found>> 6456 if Comes_From_Source (N) 6457 and then Is_Remote_Access_To_Subprogram_Type (Id) 6458 and then Ekind (Id) = E_Access_Subprogram_Type 6459 and then Present (Equivalent_Type (Id)) 6460 then 6461 -- If we are not actually generating distribution code (i.e. the 6462 -- current PCS is the dummy non-distributed version), then the 6463 -- Equivalent_Type will be missing, and Id should be treated as 6464 -- a regular access-to-subprogram type. 6465 6466 Id := Equivalent_Type (Id); 6467 Set_Chars (Selector, Chars (Id)); 6468 end if; 6469 6470 -- Ada 2005 (AI-50217): Check usage of entities in limited withed units 6471 6472 if Ekind (P_Name) = E_Package and then From_Limited_With (P_Name) then 6473 if From_Limited_With (Id) 6474 or else Is_Type (Id) 6475 or else Ekind (Id) = E_Package 6476 then 6477 null; 6478 else 6479 Error_Msg_N 6480 ("limited withed package can only be used to access incomplete " 6481 & "types", N); 6482 end if; 6483 end if; 6484 6485 if Is_Task_Type (P_Name) 6486 and then ((Ekind (Id) = E_Entry 6487 and then Nkind (Parent (N)) /= N_Attribute_Reference) 6488 or else 6489 (Ekind (Id) = E_Entry_Family 6490 and then 6491 Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) 6492 then 6493 -- If both the task type and the entry are in scope, this may still 6494 -- be the expanded name of an entry formal. 6495 6496 if In_Open_Scopes (Id) 6497 and then Nkind (Parent (N)) = N_Selected_Component 6498 then 6499 null; 6500 6501 else 6502 -- It is an entry call after all, either to the current task 6503 -- (which will deadlock) or to an enclosing task. 6504 6505 Analyze_Selected_Component (N); 6506 return; 6507 end if; 6508 end if; 6509 6510 Change_Selected_Component_To_Expanded_Name (N); 6511 6512 -- Preserve relevant elaboration-related attributes of the context which 6513 -- are no longer available or very expensive to recompute once analysis, 6514 -- resolution, and expansion are over. 6515 6516 Mark_Elaboration_Attributes 6517 (N_Id => N, 6518 Modes => True); 6519 6520 -- Set appropriate type 6521 6522 if Is_Type (Id) then 6523 Set_Etype (N, Id); 6524 else 6525 Set_Etype (N, Get_Full_View (Etype (Id))); 6526 end if; 6527 6528 -- Do style check and generate reference, but skip both steps if this 6529 -- entity has homonyms, since we may not have the right homonym set yet. 6530 -- The proper homonym will be set during the resolve phase. 6531 6532 if Has_Homonym (Id) then 6533 Set_Entity (N, Id); 6534 6535 else 6536 Set_Entity_Or_Discriminal (N, Id); 6537 6538 case Is_LHS (N) is 6539 when Yes => 6540 Generate_Reference (Id, N, 'm'); 6541 6542 when No => 6543 Generate_Reference (Id, N, 'r'); 6544 6545 when Unknown => 6546 Deferred_References.Append ((Id, N)); 6547 end case; 6548 end if; 6549 6550 -- Check for violation of No_Wide_Characters 6551 6552 Check_Wide_Character_Restriction (Id, N); 6553 6554 -- If the Ekind of the entity is Void, it means that all homonyms are 6555 -- hidden from all visibility (RM 8.3(5,14-20)). 6556 6557 if Ekind (Id) = E_Void then 6558 Premature_Usage (N); 6559 6560 elsif Is_Overloadable (Id) and then Present (Homonym (Id)) then 6561 declare 6562 H : Entity_Id := Homonym (Id); 6563 6564 begin 6565 while Present (H) loop 6566 if Scope (H) = Scope (Id) 6567 and then (not Is_Hidden (H) 6568 or else Is_Immediately_Visible (H)) 6569 then 6570 Collect_Interps (N); 6571 exit; 6572 end if; 6573 6574 H := Homonym (H); 6575 end loop; 6576 6577 -- If an extension of System is present, collect possible explicit 6578 -- overloadings declared in the extension. 6579 6580 if Chars (P_Name) = Name_System 6581 and then Scope (P_Name) = Standard_Standard 6582 and then Present (System_Extend_Unit) 6583 and then Present_System_Aux (N) 6584 then 6585 H := Current_Entity (Id); 6586 6587 while Present (H) loop 6588 if Scope (H) = System_Aux_Id then 6589 Add_One_Interp (N, H, Etype (H)); 6590 end if; 6591 6592 H := Homonym (H); 6593 end loop; 6594 end if; 6595 end; 6596 end if; 6597 6598 if Nkind (Selector_Name (N)) = N_Operator_Symbol 6599 and then Scope (Id) /= Standard_Standard 6600 then 6601 -- In addition to user-defined operators in the given scope, there 6602 -- may be an implicit instance of the predefined operator. The 6603 -- operator (defined in Standard) is found in Has_Implicit_Operator, 6604 -- and added to the interpretations. Procedure Add_One_Interp will 6605 -- determine which hides which. 6606 6607 if Has_Implicit_Operator (N) then 6608 null; 6609 end if; 6610 end if; 6611 6612 -- If there is a single interpretation for N we can generate a 6613 -- reference to the unique entity found. 6614 6615 if Is_Overloadable (Id) and then not Is_Overloaded (N) then 6616 Generate_Reference (Id, N); 6617 end if; 6618 6619 -- Mark relevant use-type and use-package clauses as effective if the 6620 -- node in question is not overloaded and therefore does not require 6621 -- resolution. 6622 6623 if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then 6624 Mark_Use_Clauses (N); 6625 end if; 6626 6627 Check_Restriction_No_Use_Of_Entity (N); 6628 6629 -- Annotate the tree by creating a variable reference marker in case the 6630 -- original variable reference is folded or optimized away. The variable 6631 -- reference marker is automatically saved for later examination by the 6632 -- ABE Processing phase. Variable references which act as actuals in a 6633 -- call require special processing and are left to Resolve_Actuals. The 6634 -- reference is a write when it appears on the left hand side of an 6635 -- assignment. 6636 6637 if Needs_Variable_Reference_Marker 6638 (N => N, 6639 Calls_OK => False) 6640 then 6641 declare 6642 Is_Assignment_LHS : constant Boolean := Is_LHS (N) = Yes; 6643 6644 begin 6645 Build_Variable_Reference_Marker 6646 (N => N, 6647 Read => not Is_Assignment_LHS, 6648 Write => Is_Assignment_LHS); 6649 end; 6650 end if; 6651 end Find_Expanded_Name; 6652 6653 -------------------- 6654 -- Find_Most_Prev -- 6655 -------------------- 6656 6657 function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is 6658 Curr : Node_Id; 6659 6660 begin 6661 -- Loop through the Prev_Use_Clause chain 6662 6663 Curr := Use_Clause; 6664 while Present (Prev_Use_Clause (Curr)) loop 6665 Curr := Prev_Use_Clause (Curr); 6666 end loop; 6667 6668 return Curr; 6669 end Find_Most_Prev; 6670 6671 ------------------------- 6672 -- Find_Renamed_Entity -- 6673 ------------------------- 6674 6675 function Find_Renamed_Entity 6676 (N : Node_Id; 6677 Nam : Node_Id; 6678 New_S : Entity_Id; 6679 Is_Actual : Boolean := False) return Entity_Id 6680 is 6681 Ind : Interp_Index; 6682 I1 : Interp_Index := 0; -- Suppress junk warnings 6683 It : Interp; 6684 It1 : Interp; 6685 Old_S : Entity_Id; 6686 Inst : Entity_Id; 6687 6688 function Is_Visible_Operation (Op : Entity_Id) return Boolean; 6689 -- If the renamed entity is an implicit operator, check whether it is 6690 -- visible because its operand type is properly visible. This check 6691 -- applies to explicit renamed entities that appear in the source in a 6692 -- renaming declaration or a formal subprogram instance, but not to 6693 -- default generic actuals with a name. 6694 6695 function Report_Overload return Entity_Id; 6696 -- List possible interpretations, and specialize message in the 6697 -- case of a generic actual. 6698 6699 function Within (Inner, Outer : Entity_Id) return Boolean; 6700 -- Determine whether a candidate subprogram is defined within the 6701 -- enclosing instance. If yes, it has precedence over outer candidates. 6702 6703 -------------------------- 6704 -- Is_Visible_Operation -- 6705 -------------------------- 6706 6707 function Is_Visible_Operation (Op : Entity_Id) return Boolean is 6708 Scop : Entity_Id; 6709 Typ : Entity_Id; 6710 Btyp : Entity_Id; 6711 6712 begin 6713 if Ekind (Op) /= E_Operator 6714 or else Scope (Op) /= Standard_Standard 6715 or else (In_Instance 6716 and then (not Is_Actual 6717 or else Present (Enclosing_Instance))) 6718 then 6719 return True; 6720 6721 else 6722 -- For a fixed point type operator, check the resulting type, 6723 -- because it may be a mixed mode integer * fixed operation. 6724 6725 if Present (Next_Formal (First_Formal (New_S))) 6726 and then Is_Fixed_Point_Type (Etype (New_S)) 6727 then 6728 Typ := Etype (New_S); 6729 else 6730 Typ := Etype (First_Formal (New_S)); 6731 end if; 6732 6733 Btyp := Base_Type (Typ); 6734 6735 if Nkind (Nam) /= N_Expanded_Name then 6736 return (In_Open_Scopes (Scope (Btyp)) 6737 or else Is_Potentially_Use_Visible (Btyp) 6738 or else In_Use (Btyp) 6739 or else In_Use (Scope (Btyp))); 6740 6741 else 6742 Scop := Entity (Prefix (Nam)); 6743 6744 if Ekind (Scop) = E_Package 6745 and then Present (Renamed_Object (Scop)) 6746 then 6747 Scop := Renamed_Object (Scop); 6748 end if; 6749 6750 -- Operator is visible if prefix of expanded name denotes 6751 -- scope of type, or else type is defined in System_Aux 6752 -- and the prefix denotes System. 6753 6754 return Scope (Btyp) = Scop 6755 or else (Scope (Btyp) = System_Aux_Id 6756 and then Scope (Scope (Btyp)) = Scop); 6757 end if; 6758 end if; 6759 end Is_Visible_Operation; 6760 6761 ------------ 6762 -- Within -- 6763 ------------ 6764 6765 function Within (Inner, Outer : Entity_Id) return Boolean is 6766 Sc : Entity_Id; 6767 6768 begin 6769 Sc := Scope (Inner); 6770 while Sc /= Standard_Standard loop 6771 if Sc = Outer then 6772 return True; 6773 else 6774 Sc := Scope (Sc); 6775 end if; 6776 end loop; 6777 6778 return False; 6779 end Within; 6780 6781 --------------------- 6782 -- Report_Overload -- 6783 --------------------- 6784 6785 function Report_Overload return Entity_Id is 6786 begin 6787 if Is_Actual then 6788 Error_Msg_NE -- CODEFIX 6789 ("ambiguous actual subprogram&, " & 6790 "possible interpretations:", N, Nam); 6791 else 6792 Error_Msg_N -- CODEFIX 6793 ("ambiguous subprogram, " & 6794 "possible interpretations:", N); 6795 end if; 6796 6797 List_Interps (Nam, N); 6798 return Old_S; 6799 end Report_Overload; 6800 6801 -- Start of processing for Find_Renamed_Entity 6802 6803 begin 6804 Old_S := Any_Id; 6805 Candidate_Renaming := Empty; 6806 6807 if Is_Overloaded (Nam) then 6808 Get_First_Interp (Nam, Ind, It); 6809 while Present (It.Nam) loop 6810 if Entity_Matches_Spec (It.Nam, New_S) 6811 and then Is_Visible_Operation (It.Nam) 6812 then 6813 if Old_S /= Any_Id then 6814 6815 -- Note: The call to Disambiguate only happens if a 6816 -- previous interpretation was found, in which case I1 6817 -- has received a value. 6818 6819 It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S)); 6820 6821 if It1 = No_Interp then 6822 Inst := Enclosing_Instance; 6823 6824 if Present (Inst) then 6825 if Within (It.Nam, Inst) then 6826 if Within (Old_S, Inst) then 6827 6828 -- Choose the innermost subprogram, which would 6829 -- have hidden the outer one in the generic. 6830 6831 if Scope_Depth (It.Nam) < 6832 Scope_Depth (Old_S) 6833 then 6834 return Old_S; 6835 else 6836 return It.Nam; 6837 end if; 6838 end if; 6839 6840 elsif Within (Old_S, Inst) then 6841 return (Old_S); 6842 6843 else 6844 return Report_Overload; 6845 end if; 6846 6847 -- If not within an instance, ambiguity is real 6848 6849 else 6850 return Report_Overload; 6851 end if; 6852 6853 else 6854 Old_S := It1.Nam; 6855 exit; 6856 end if; 6857 6858 else 6859 I1 := Ind; 6860 Old_S := It.Nam; 6861 end if; 6862 6863 elsif 6864 Present (First_Formal (It.Nam)) 6865 and then Present (First_Formal (New_S)) 6866 and then (Base_Type (Etype (First_Formal (It.Nam))) = 6867 Base_Type (Etype (First_Formal (New_S)))) 6868 then 6869 Candidate_Renaming := It.Nam; 6870 end if; 6871 6872 Get_Next_Interp (Ind, It); 6873 end loop; 6874 6875 Set_Entity (Nam, Old_S); 6876 6877 if Old_S /= Any_Id then 6878 Set_Is_Overloaded (Nam, False); 6879 end if; 6880 6881 -- Non-overloaded case 6882 6883 else 6884 if Is_Actual 6885 and then Present (Enclosing_Instance) 6886 and then Entity_Matches_Spec (Entity (Nam), New_S) 6887 then 6888 Old_S := Entity (Nam); 6889 6890 elsif Entity_Matches_Spec (Entity (Nam), New_S) then 6891 Candidate_Renaming := New_S; 6892 6893 if Is_Visible_Operation (Entity (Nam)) then 6894 Old_S := Entity (Nam); 6895 end if; 6896 6897 elsif Present (First_Formal (Entity (Nam))) 6898 and then Present (First_Formal (New_S)) 6899 and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = 6900 Base_Type (Etype (First_Formal (New_S)))) 6901 then 6902 Candidate_Renaming := Entity (Nam); 6903 end if; 6904 end if; 6905 6906 return Old_S; 6907 end Find_Renamed_Entity; 6908 6909 ----------------------------- 6910 -- Find_Selected_Component -- 6911 ----------------------------- 6912 6913 procedure Find_Selected_Component (N : Node_Id) is 6914 P : constant Node_Id := Prefix (N); 6915 6916 P_Name : Entity_Id; 6917 -- Entity denoted by prefix 6918 6919 P_Type : Entity_Id; 6920 -- and its type 6921 6922 Nam : Node_Id; 6923 6924 function Available_Subtype return Boolean; 6925 -- A small optimization: if the prefix is constrained and the component 6926 -- is an array type we may already have a usable subtype for it, so we 6927 -- can use it rather than generating a new one, because the bounds 6928 -- will be the values of the discriminants and not discriminant refs. 6929 -- This simplifies value tracing in GNATProve. For consistency, both 6930 -- the entity name and the subtype come from the constrained component. 6931 6932 -- This is only used in GNATProve mode: when generating code it may be 6933 -- necessary to create an itype in the scope of use of the selected 6934 -- component, e.g. in the context of a expanded record equality. 6935 6936 function Is_Reference_In_Subunit return Boolean; 6937 -- In a subunit, the scope depth is not a proper measure of hiding, 6938 -- because the context of the proper body may itself hide entities in 6939 -- parent units. This rare case requires inspecting the tree directly 6940 -- because the proper body is inserted in the main unit and its context 6941 -- is simply added to that of the parent. 6942 6943 ----------------------- 6944 -- Available_Subtype -- 6945 ----------------------- 6946 6947 function Available_Subtype return Boolean is 6948 Comp : Entity_Id; 6949 6950 begin 6951 if GNATprove_Mode then 6952 Comp := First_Entity (Etype (P)); 6953 while Present (Comp) loop 6954 if Chars (Comp) = Chars (Selector_Name (N)) then 6955 Set_Etype (N, Etype (Comp)); 6956 Set_Entity (Selector_Name (N), Comp); 6957 Set_Etype (Selector_Name (N), Etype (Comp)); 6958 return True; 6959 end if; 6960 6961 Next_Component (Comp); 6962 end loop; 6963 end if; 6964 6965 return False; 6966 end Available_Subtype; 6967 6968 ----------------------------- 6969 -- Is_Reference_In_Subunit -- 6970 ----------------------------- 6971 6972 function Is_Reference_In_Subunit return Boolean is 6973 Clause : Node_Id; 6974 Comp_Unit : Node_Id; 6975 6976 begin 6977 Comp_Unit := N; 6978 while Present (Comp_Unit) 6979 and then Nkind (Comp_Unit) /= N_Compilation_Unit 6980 loop 6981 Comp_Unit := Parent (Comp_Unit); 6982 end loop; 6983 6984 if No (Comp_Unit) or else Nkind (Unit (Comp_Unit)) /= N_Subunit then 6985 return False; 6986 end if; 6987 6988 -- Now check whether the package is in the context of the subunit 6989 6990 Clause := First (Context_Items (Comp_Unit)); 6991 while Present (Clause) loop 6992 if Nkind (Clause) = N_With_Clause 6993 and then Entity (Name (Clause)) = P_Name 6994 then 6995 return True; 6996 end if; 6997 6998 Clause := Next (Clause); 6999 end loop; 7000 7001 return False; 7002 end Is_Reference_In_Subunit; 7003 7004 -- Start of processing for Find_Selected_Component 7005 7006 begin 7007 Analyze (P); 7008 7009 if Nkind (P) = N_Error then 7010 return; 7011 end if; 7012 7013 -- Selector name cannot be a character literal or an operator symbol in 7014 -- SPARK, except for the operator symbol in a renaming. 7015 7016 if Restriction_Check_Required (SPARK_05) then 7017 if Nkind (Selector_Name (N)) = N_Character_Literal then 7018 Check_SPARK_05_Restriction 7019 ("character literal cannot be prefixed", N); 7020 elsif Nkind (Selector_Name (N)) = N_Operator_Symbol 7021 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration 7022 then 7023 Check_SPARK_05_Restriction 7024 ("operator symbol cannot be prefixed", N); 7025 end if; 7026 end if; 7027 7028 -- If the selector already has an entity, the node has been constructed 7029 -- in the course of expansion, and is known to be valid. Do not verify 7030 -- that it is defined for the type (it may be a private component used 7031 -- in the expansion of record equality). 7032 7033 if Present (Entity (Selector_Name (N))) then 7034 if No (Etype (N)) or else Etype (N) = Any_Type then 7035 declare 7036 Sel_Name : constant Node_Id := Selector_Name (N); 7037 Selector : constant Entity_Id := Entity (Sel_Name); 7038 C_Etype : Node_Id; 7039 7040 begin 7041 Set_Etype (Sel_Name, Etype (Selector)); 7042 7043 if not Is_Entity_Name (P) then 7044 Resolve (P); 7045 end if; 7046 7047 -- Build an actual subtype except for the first parameter 7048 -- of an init proc, where this actual subtype is by 7049 -- definition incorrect, since the object is uninitialized 7050 -- (and does not even have defined discriminants etc.) 7051 7052 if Is_Entity_Name (P) 7053 and then Ekind (Entity (P)) = E_Function 7054 then 7055 Nam := New_Copy (P); 7056 7057 if Is_Overloaded (P) then 7058 Save_Interps (P, Nam); 7059 end if; 7060 7061 Rewrite (P, Make_Function_Call (Sloc (P), Name => Nam)); 7062 Analyze_Call (P); 7063 Analyze_Selected_Component (N); 7064 return; 7065 7066 elsif Ekind (Selector) = E_Component 7067 and then (not Is_Entity_Name (P) 7068 or else Chars (Entity (P)) /= Name_uInit) 7069 then 7070 -- Check if we already have an available subtype we can use 7071 7072 if Ekind (Etype (P)) = E_Record_Subtype 7073 and then Nkind (Parent (Etype (P))) = N_Subtype_Declaration 7074 and then Is_Array_Type (Etype (Selector)) 7075 and then not Is_Packed (Etype (Selector)) 7076 and then Available_Subtype 7077 then 7078 return; 7079 7080 -- Do not build the subtype when referencing components of 7081 -- dispatch table wrappers. Required to avoid generating 7082 -- elaboration code with HI runtimes. 7083 7084 elsif RTU_Loaded (Ada_Tags) 7085 and then 7086 ((RTE_Available (RE_Dispatch_Table_Wrapper) 7087 and then Scope (Selector) = 7088 RTE (RE_Dispatch_Table_Wrapper)) 7089 or else 7090 (RTE_Available (RE_No_Dispatch_Table_Wrapper) 7091 and then Scope (Selector) = 7092 RTE (RE_No_Dispatch_Table_Wrapper))) 7093 then 7094 C_Etype := Empty; 7095 else 7096 C_Etype := 7097 Build_Actual_Subtype_Of_Component 7098 (Etype (Selector), N); 7099 end if; 7100 7101 else 7102 C_Etype := Empty; 7103 end if; 7104 7105 if No (C_Etype) then 7106 C_Etype := Etype (Selector); 7107 else 7108 Insert_Action (N, C_Etype); 7109 C_Etype := Defining_Identifier (C_Etype); 7110 end if; 7111 7112 Set_Etype (N, C_Etype); 7113 end; 7114 7115 -- If this is the name of an entry or protected operation, and 7116 -- the prefix is an access type, insert an explicit dereference, 7117 -- so that entry calls are treated uniformly. 7118 7119 if Is_Access_Type (Etype (P)) 7120 and then Is_Concurrent_Type (Designated_Type (Etype (P))) 7121 then 7122 declare 7123 New_P : constant Node_Id := 7124 Make_Explicit_Dereference (Sloc (P), 7125 Prefix => Relocate_Node (P)); 7126 begin 7127 Rewrite (P, New_P); 7128 Set_Etype (P, Designated_Type (Etype (Prefix (P)))); 7129 end; 7130 end if; 7131 7132 -- If the selected component appears within a default expression 7133 -- and it has an actual subtype, the preanalysis has not yet 7134 -- completed its analysis, because Insert_Actions is disabled in 7135 -- that context. Within the init proc of the enclosing type we 7136 -- must complete this analysis, if an actual subtype was created. 7137 7138 elsif Inside_Init_Proc then 7139 declare 7140 Typ : constant Entity_Id := Etype (N); 7141 Decl : constant Node_Id := Declaration_Node (Typ); 7142 begin 7143 if Nkind (Decl) = N_Subtype_Declaration 7144 and then not Analyzed (Decl) 7145 and then Is_List_Member (Decl) 7146 and then No (Parent (Decl)) 7147 then 7148 Remove (Decl); 7149 Insert_Action (N, Decl); 7150 end if; 7151 end; 7152 end if; 7153 7154 return; 7155 7156 elsif Is_Entity_Name (P) then 7157 P_Name := Entity (P); 7158 7159 -- The prefix may denote an enclosing type which is the completion 7160 -- of an incomplete type declaration. 7161 7162 if Is_Type (P_Name) then 7163 Set_Entity (P, Get_Full_View (P_Name)); 7164 Set_Etype (P, Entity (P)); 7165 P_Name := Entity (P); 7166 end if; 7167 7168 P_Type := Base_Type (Etype (P)); 7169 7170 if Debug_Flag_E then 7171 Write_Str ("Found prefix type to be "); 7172 Write_Entity_Info (P_Type, " "); Write_Eol; 7173 end if; 7174 7175 -- The designated type may be a limited view with no components. 7176 -- Check whether the non-limited view is available, because in some 7177 -- cases this will not be set when installing the context. Rewrite 7178 -- the node by introducing an explicit dereference at once, and 7179 -- setting the type of the rewritten prefix to the non-limited view 7180 -- of the original designated type. 7181 7182 if Is_Access_Type (P_Type) then 7183 declare 7184 Desig_Typ : constant Entity_Id := 7185 Directly_Designated_Type (P_Type); 7186 7187 begin 7188 if Is_Incomplete_Type (Desig_Typ) 7189 and then From_Limited_With (Desig_Typ) 7190 and then Present (Non_Limited_View (Desig_Typ)) 7191 then 7192 Rewrite (P, 7193 Make_Explicit_Dereference (Sloc (P), 7194 Prefix => Relocate_Node (P))); 7195 7196 Set_Etype (P, Get_Full_View (Non_Limited_View (Desig_Typ))); 7197 P_Type := Etype (P); 7198 end if; 7199 end; 7200 end if; 7201 7202 -- First check for components of a record object (not the 7203 -- result of a call, which is handled below). 7204 7205 if Is_Appropriate_For_Record (P_Type) 7206 and then not Is_Overloadable (P_Name) 7207 and then not Is_Type (P_Name) 7208 then 7209 -- Selected component of record. Type checking will validate 7210 -- name of selector. 7211 7212 -- ??? Could we rewrite an implicit dereference into an explicit 7213 -- one here? 7214 7215 Analyze_Selected_Component (N); 7216 7217 -- Reference to type name in predicate/invariant expression 7218 7219 elsif Is_Appropriate_For_Entry_Prefix (P_Type) 7220 and then not In_Open_Scopes (P_Name) 7221 and then (not Is_Concurrent_Type (Etype (P_Name)) 7222 or else not In_Open_Scopes (Etype (P_Name))) 7223 then 7224 -- Call to protected operation or entry. Type checking is 7225 -- needed on the prefix. 7226 7227 Analyze_Selected_Component (N); 7228 7229 elsif (In_Open_Scopes (P_Name) 7230 and then Ekind (P_Name) /= E_Void 7231 and then not Is_Overloadable (P_Name)) 7232 or else (Is_Concurrent_Type (Etype (P_Name)) 7233 and then In_Open_Scopes (Etype (P_Name))) 7234 then 7235 -- Prefix denotes an enclosing loop, block, or task, i.e. an 7236 -- enclosing construct that is not a subprogram or accept. 7237 7238 -- A special case: a protected body may call an operation 7239 -- on an external object of the same type, in which case it 7240 -- is not an expanded name. If the prefix is the type itself, 7241 -- or the context is a single synchronized object it can only 7242 -- be interpreted as an expanded name. 7243 7244 if Is_Concurrent_Type (Etype (P_Name)) then 7245 if Is_Type (P_Name) 7246 or else Present (Anonymous_Object (Etype (P_Name))) 7247 then 7248 Find_Expanded_Name (N); 7249 7250 else 7251 Analyze_Selected_Component (N); 7252 return; 7253 end if; 7254 7255 else 7256 Find_Expanded_Name (N); 7257 end if; 7258 7259 elsif Ekind (P_Name) = E_Package then 7260 Find_Expanded_Name (N); 7261 7262 elsif Is_Overloadable (P_Name) then 7263 7264 -- The subprogram may be a renaming (of an enclosing scope) as 7265 -- in the case of the name of the generic within an instantiation. 7266 7267 if Ekind_In (P_Name, E_Procedure, E_Function) 7268 and then Present (Alias (P_Name)) 7269 and then Is_Generic_Instance (Alias (P_Name)) 7270 then 7271 P_Name := Alias (P_Name); 7272 end if; 7273 7274 if Is_Overloaded (P) then 7275 7276 -- The prefix must resolve to a unique enclosing construct 7277 7278 declare 7279 Found : Boolean := False; 7280 Ind : Interp_Index; 7281 It : Interp; 7282 7283 begin 7284 Get_First_Interp (P, Ind, It); 7285 while Present (It.Nam) loop 7286 if In_Open_Scopes (It.Nam) then 7287 if Found then 7288 Error_Msg_N ( 7289 "prefix must be unique enclosing scope", N); 7290 Set_Entity (N, Any_Id); 7291 Set_Etype (N, Any_Type); 7292 return; 7293 7294 else 7295 Found := True; 7296 P_Name := It.Nam; 7297 end if; 7298 end if; 7299 7300 Get_Next_Interp (Ind, It); 7301 end loop; 7302 end; 7303 end if; 7304 7305 if In_Open_Scopes (P_Name) then 7306 Set_Entity (P, P_Name); 7307 Set_Is_Overloaded (P, False); 7308 Find_Expanded_Name (N); 7309 7310 else 7311 -- If no interpretation as an expanded name is possible, it 7312 -- must be a selected component of a record returned by a 7313 -- function call. Reformat prefix as a function call, the rest 7314 -- is done by type resolution. 7315 7316 -- Error if the prefix is procedure or entry, as is P.X 7317 7318 if Ekind (P_Name) /= E_Function 7319 and then 7320 (not Is_Overloaded (P) 7321 or else Nkind (Parent (N)) = N_Procedure_Call_Statement) 7322 then 7323 -- Prefix may mention a package that is hidden by a local 7324 -- declaration: let the user know. Scan the full homonym 7325 -- chain, the candidate package may be anywhere on it. 7326 7327 if Present (Homonym (Current_Entity (P_Name))) then 7328 P_Name := Current_Entity (P_Name); 7329 7330 while Present (P_Name) loop 7331 exit when Ekind (P_Name) = E_Package; 7332 P_Name := Homonym (P_Name); 7333 end loop; 7334 7335 if Present (P_Name) then 7336 if not Is_Reference_In_Subunit then 7337 Error_Msg_Sloc := Sloc (Entity (Prefix (N))); 7338 Error_Msg_NE 7339 ("package& is hidden by declaration#", N, P_Name); 7340 end if; 7341 7342 Set_Entity (Prefix (N), P_Name); 7343 Find_Expanded_Name (N); 7344 return; 7345 7346 else 7347 P_Name := Entity (Prefix (N)); 7348 end if; 7349 end if; 7350 7351 Error_Msg_NE 7352 ("invalid prefix in selected component&", N, P_Name); 7353 Change_Selected_Component_To_Expanded_Name (N); 7354 Set_Entity (N, Any_Id); 7355 Set_Etype (N, Any_Type); 7356 7357 -- Here we have a function call, so do the reformatting 7358 7359 else 7360 Nam := New_Copy (P); 7361 Save_Interps (P, Nam); 7362 7363 -- We use Replace here because this is one of those cases 7364 -- where the parser has missclassified the node, and we fix 7365 -- things up and then do the semantic analysis on the fixed 7366 -- up node. Normally we do this using one of the Sinfo.CN 7367 -- routines, but this is too tricky for that. 7368 7369 -- Note that using Rewrite would be wrong, because we would 7370 -- have a tree where the original node is unanalyzed, and 7371 -- this violates the required interface for ASIS. 7372 7373 Replace (P, 7374 Make_Function_Call (Sloc (P), Name => Nam)); 7375 7376 -- Now analyze the reformatted node 7377 7378 Analyze_Call (P); 7379 7380 -- If the prefix is illegal after this transformation, there 7381 -- may be visibility errors on the prefix. The safest is to 7382 -- treat the selected component as an error. 7383 7384 if Error_Posted (P) then 7385 Set_Etype (N, Any_Type); 7386 return; 7387 7388 else 7389 Analyze_Selected_Component (N); 7390 end if; 7391 end if; 7392 end if; 7393 7394 -- Remaining cases generate various error messages 7395 7396 else 7397 -- Format node as expanded name, to avoid cascaded errors 7398 7399 -- If the limited_with transformation was applied earlier, restore 7400 -- source for proper error reporting. 7401 7402 if not Comes_From_Source (P) 7403 and then Nkind (P) = N_Explicit_Dereference 7404 then 7405 Rewrite (P, Prefix (P)); 7406 P_Type := Etype (P); 7407 end if; 7408 7409 Change_Selected_Component_To_Expanded_Name (N); 7410 Set_Entity (N, Any_Id); 7411 Set_Etype (N, Any_Type); 7412 7413 -- Issue error message, but avoid this if error issued already. 7414 -- Use identifier of prefix if one is available. 7415 7416 if P_Name = Any_Id then 7417 null; 7418 7419 -- It is not an error if the prefix is the current instance of 7420 -- type name, e.g. the expression of a type aspect, when it is 7421 -- analyzed for ASIS use. 7422 7423 elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then 7424 null; 7425 7426 elsif Ekind (P_Name) = E_Void then 7427 Premature_Usage (P); 7428 7429 elsif Nkind (P) /= N_Attribute_Reference then 7430 7431 -- This may have been meant as a prefixed call to a primitive 7432 -- of an untagged type. If it is a function call check type of 7433 -- its first formal and add explanation. 7434 7435 declare 7436 F : constant Entity_Id := 7437 Current_Entity (Selector_Name (N)); 7438 begin 7439 if Present (F) 7440 and then Is_Overloadable (F) 7441 and then Present (First_Entity (F)) 7442 and then not Is_Tagged_Type (Etype (First_Entity (F))) 7443 then 7444 Error_Msg_N 7445 ("prefixed call is only allowed for objects of a " 7446 & "tagged type", N); 7447 end if; 7448 end; 7449 7450 Error_Msg_N ("invalid prefix in selected component&", P); 7451 7452 if Is_Access_Type (P_Type) 7453 and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type 7454 then 7455 Error_Msg_N 7456 ("\dereference must not be of an incomplete type " 7457 & "(RM 3.10.1)", P); 7458 end if; 7459 7460 else 7461 Error_Msg_N ("invalid prefix in selected component", P); 7462 end if; 7463 end if; 7464 7465 -- Selector name is restricted in SPARK 7466 7467 if Nkind (N) = N_Expanded_Name 7468 and then Restriction_Check_Required (SPARK_05) 7469 then 7470 if Is_Subprogram (P_Name) then 7471 Check_SPARK_05_Restriction 7472 ("prefix of expanded name cannot be a subprogram", P); 7473 elsif Ekind (P_Name) = E_Loop then 7474 Check_SPARK_05_Restriction 7475 ("prefix of expanded name cannot be a loop statement", P); 7476 end if; 7477 end if; 7478 7479 else 7480 -- If prefix is not the name of an entity, it must be an expression, 7481 -- whose type is appropriate for a record. This is determined by 7482 -- type resolution. 7483 7484 Analyze_Selected_Component (N); 7485 end if; 7486 7487 Analyze_Dimension (N); 7488 end Find_Selected_Component; 7489 7490 --------------- 7491 -- Find_Type -- 7492 --------------- 7493 7494 procedure Find_Type (N : Node_Id) is 7495 C : Entity_Id; 7496 Typ : Entity_Id; 7497 T : Entity_Id; 7498 T_Name : Entity_Id; 7499 7500 begin 7501 if N = Error then 7502 return; 7503 7504 elsif Nkind (N) = N_Attribute_Reference then 7505 7506 -- Class attribute. This is not valid in Ada 83 mode, but we do not 7507 -- need to enforce that at this point, since the declaration of the 7508 -- tagged type in the prefix would have been flagged already. 7509 7510 if Attribute_Name (N) = Name_Class then 7511 Check_Restriction (No_Dispatch, N); 7512 Find_Type (Prefix (N)); 7513 7514 -- Propagate error from bad prefix 7515 7516 if Etype (Prefix (N)) = Any_Type then 7517 Set_Entity (N, Any_Type); 7518 Set_Etype (N, Any_Type); 7519 return; 7520 end if; 7521 7522 T := Base_Type (Entity (Prefix (N))); 7523 7524 -- Case where type is not known to be tagged. Its appearance in 7525 -- the prefix of the 'Class attribute indicates that the full view 7526 -- will be tagged. 7527 7528 if not Is_Tagged_Type (T) then 7529 if Ekind (T) = E_Incomplete_Type then 7530 7531 -- It is legal to denote the class type of an incomplete 7532 -- type. The full type will have to be tagged, of course. 7533 -- In Ada 2005 this usage is declared obsolescent, so we 7534 -- warn accordingly. This usage is only legal if the type 7535 -- is completed in the current scope, and not for a limited 7536 -- view of a type. 7537 7538 if Ada_Version >= Ada_2005 then 7539 7540 -- Test whether the Available_View of a limited type view 7541 -- is tagged, since the limited view may not be marked as 7542 -- tagged if the type itself has an untagged incomplete 7543 -- type view in its package. 7544 7545 if From_Limited_With (T) 7546 and then not Is_Tagged_Type (Available_View (T)) 7547 then 7548 Error_Msg_N 7549 ("prefix of Class attribute must be tagged", N); 7550 Set_Etype (N, Any_Type); 7551 Set_Entity (N, Any_Type); 7552 return; 7553 7554 -- ??? This test is temporarily disabled (always 7555 -- False) because it causes an unwanted warning on 7556 -- GNAT sources (built with -gnatg, which includes 7557 -- Warn_On_Obsolescent_ Feature). Once this issue 7558 -- is cleared in the sources, it can be enabled. 7559 7560 elsif Warn_On_Obsolescent_Feature and then False then 7561 Error_Msg_N 7562 ("applying 'Class to an untagged incomplete type" 7563 & " is an obsolescent feature (RM J.11)?r?", N); 7564 end if; 7565 end if; 7566 7567 Set_Is_Tagged_Type (T); 7568 Set_Direct_Primitive_Operations (T, New_Elmt_List); 7569 Make_Class_Wide_Type (T); 7570 Set_Entity (N, Class_Wide_Type (T)); 7571 Set_Etype (N, Class_Wide_Type (T)); 7572 7573 elsif Ekind (T) = E_Private_Type 7574 and then not Is_Generic_Type (T) 7575 and then In_Private_Part (Scope (T)) 7576 then 7577 -- The Class attribute can be applied to an untagged private 7578 -- type fulfilled by a tagged type prior to the full type 7579 -- declaration (but only within the parent package's private 7580 -- part). Create the class-wide type now and check that the 7581 -- full type is tagged later during its analysis. Note that 7582 -- we do not mark the private type as tagged, unlike the 7583 -- case of incomplete types, because the type must still 7584 -- appear untagged to outside units. 7585 7586 if No (Class_Wide_Type (T)) then 7587 Make_Class_Wide_Type (T); 7588 end if; 7589 7590 Set_Entity (N, Class_Wide_Type (T)); 7591 Set_Etype (N, Class_Wide_Type (T)); 7592 7593 else 7594 -- Should we introduce a type Any_Tagged and use Wrong_Type 7595 -- here, it would be a bit more consistent??? 7596 7597 Error_Msg_NE 7598 ("tagged type required, found}", 7599 Prefix (N), First_Subtype (T)); 7600 Set_Entity (N, Any_Type); 7601 return; 7602 end if; 7603 7604 -- Case of tagged type 7605 7606 else 7607 if Is_Concurrent_Type (T) then 7608 if No (Corresponding_Record_Type (Entity (Prefix (N)))) then 7609 7610 -- Previous error. Create a class-wide type for the 7611 -- synchronized type itself, with minimal semantic 7612 -- attributes, to catch other errors in some ACATS tests. 7613 7614 pragma Assert (Serious_Errors_Detected /= 0); 7615 Make_Class_Wide_Type (T); 7616 C := Class_Wide_Type (T); 7617 Set_First_Entity (C, First_Entity (T)); 7618 7619 else 7620 C := Class_Wide_Type 7621 (Corresponding_Record_Type (Entity (Prefix (N)))); 7622 end if; 7623 7624 else 7625 C := Class_Wide_Type (Entity (Prefix (N))); 7626 end if; 7627 7628 Set_Entity_With_Checks (N, C); 7629 Generate_Reference (C, N); 7630 Set_Etype (N, C); 7631 end if; 7632 7633 -- Base attribute, not allowed in Ada 83 7634 7635 elsif Attribute_Name (N) = Name_Base then 7636 Error_Msg_Name_1 := Name_Base; 7637 Check_SPARK_05_Restriction 7638 ("attribute% is only allowed as prefix of another attribute", N); 7639 7640 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 7641 Error_Msg_N 7642 ("(Ada 83) Base attribute not allowed in subtype mark", N); 7643 7644 else 7645 Find_Type (Prefix (N)); 7646 Typ := Entity (Prefix (N)); 7647 7648 if Ada_Version >= Ada_95 7649 and then not Is_Scalar_Type (Typ) 7650 and then not Is_Generic_Type (Typ) 7651 then 7652 Error_Msg_N 7653 ("prefix of Base attribute must be scalar type", 7654 Prefix (N)); 7655 7656 elsif Warn_On_Redundant_Constructs 7657 and then Base_Type (Typ) = Typ 7658 then 7659 Error_Msg_NE -- CODEFIX 7660 ("redundant attribute, & is its own base type?r?", N, Typ); 7661 end if; 7662 7663 T := Base_Type (Typ); 7664 7665 -- Rewrite attribute reference with type itself (see similar 7666 -- processing in Analyze_Attribute, case Base). Preserve prefix 7667 -- if present, for other legality checks. 7668 7669 if Nkind (Prefix (N)) = N_Expanded_Name then 7670 Rewrite (N, 7671 Make_Expanded_Name (Sloc (N), 7672 Chars => Chars (T), 7673 Prefix => New_Copy (Prefix (Prefix (N))), 7674 Selector_Name => New_Occurrence_Of (T, Sloc (N)))); 7675 7676 else 7677 Rewrite (N, New_Occurrence_Of (T, Sloc (N))); 7678 end if; 7679 7680 Set_Entity (N, T); 7681 Set_Etype (N, T); 7682 end if; 7683 7684 elsif Attribute_Name (N) = Name_Stub_Type then 7685 7686 -- This is handled in Analyze_Attribute 7687 7688 Analyze (N); 7689 7690 -- All other attributes are invalid in a subtype mark 7691 7692 else 7693 Error_Msg_N ("invalid attribute in subtype mark", N); 7694 end if; 7695 7696 else 7697 Analyze (N); 7698 7699 if Is_Entity_Name (N) then 7700 T_Name := Entity (N); 7701 else 7702 Error_Msg_N ("subtype mark required in this context", N); 7703 Set_Etype (N, Any_Type); 7704 return; 7705 end if; 7706 7707 if T_Name = Any_Id or else Etype (N) = Any_Type then 7708 7709 -- Undefined id. Make it into a valid type 7710 7711 Set_Entity (N, Any_Type); 7712 7713 elsif not Is_Type (T_Name) 7714 and then T_Name /= Standard_Void_Type 7715 then 7716 Error_Msg_Sloc := Sloc (T_Name); 7717 Error_Msg_N ("subtype mark required in this context", N); 7718 Error_Msg_NE ("\\found & declared#", N, T_Name); 7719 Set_Entity (N, Any_Type); 7720 7721 else 7722 -- If the type is an incomplete type created to handle 7723 -- anonymous access components of a record type, then the 7724 -- incomplete type is the visible entity and subsequent 7725 -- references will point to it. Mark the original full 7726 -- type as referenced, to prevent spurious warnings. 7727 7728 if Is_Incomplete_Type (T_Name) 7729 and then Present (Full_View (T_Name)) 7730 and then not Comes_From_Source (T_Name) 7731 then 7732 Set_Referenced (Full_View (T_Name)); 7733 end if; 7734 7735 T_Name := Get_Full_View (T_Name); 7736 7737 -- Ada 2005 (AI-251, AI-50217): Handle interfaces visible through 7738 -- limited-with clauses 7739 7740 if From_Limited_With (T_Name) 7741 and then Ekind (T_Name) in Incomplete_Kind 7742 and then Present (Non_Limited_View (T_Name)) 7743 and then Is_Interface (Non_Limited_View (T_Name)) 7744 then 7745 T_Name := Non_Limited_View (T_Name); 7746 end if; 7747 7748 if In_Open_Scopes (T_Name) then 7749 if Ekind (Base_Type (T_Name)) = E_Task_Type then 7750 7751 -- In Ada 2005, a task name can be used in an access 7752 -- definition within its own body. It cannot be used 7753 -- in the discriminant part of the task declaration, 7754 -- nor anywhere else in the declaration because entries 7755 -- cannot have access parameters. 7756 7757 if Ada_Version >= Ada_2005 7758 and then Nkind (Parent (N)) = N_Access_Definition 7759 then 7760 Set_Entity (N, T_Name); 7761 Set_Etype (N, T_Name); 7762 7763 if Has_Completion (T_Name) then 7764 return; 7765 7766 else 7767 Error_Msg_N 7768 ("task type cannot be used as type mark " & 7769 "within its own declaration", N); 7770 end if; 7771 7772 else 7773 Error_Msg_N 7774 ("task type cannot be used as type mark " & 7775 "within its own spec or body", N); 7776 end if; 7777 7778 elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then 7779 7780 -- In Ada 2005, a protected name can be used in an access 7781 -- definition within its own body. 7782 7783 if Ada_Version >= Ada_2005 7784 and then Nkind (Parent (N)) = N_Access_Definition 7785 then 7786 Set_Entity (N, T_Name); 7787 Set_Etype (N, T_Name); 7788 return; 7789 7790 else 7791 Error_Msg_N 7792 ("protected type cannot be used as type mark " & 7793 "within its own spec or body", N); 7794 end if; 7795 7796 else 7797 Error_Msg_N ("type declaration cannot refer to itself", N); 7798 end if; 7799 7800 Set_Etype (N, Any_Type); 7801 Set_Entity (N, Any_Type); 7802 Set_Error_Posted (T_Name); 7803 return; 7804 end if; 7805 7806 Set_Entity (N, T_Name); 7807 Set_Etype (N, T_Name); 7808 end if; 7809 end if; 7810 7811 if Present (Etype (N)) and then Comes_From_Source (N) then 7812 if Is_Fixed_Point_Type (Etype (N)) then 7813 Check_Restriction (No_Fixed_Point, N); 7814 elsif Is_Floating_Point_Type (Etype (N)) then 7815 Check_Restriction (No_Floating_Point, N); 7816 end if; 7817 7818 -- A Ghost type must appear in a specific context 7819 7820 if Is_Ghost_Entity (Etype (N)) then 7821 Check_Ghost_Context (Etype (N), N); 7822 end if; 7823 end if; 7824 end Find_Type; 7825 7826 ------------------------------------ 7827 -- Has_Implicit_Character_Literal -- 7828 ------------------------------------ 7829 7830 function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is 7831 Id : Entity_Id; 7832 Found : Boolean := False; 7833 P : constant Entity_Id := Entity (Prefix (N)); 7834 Priv_Id : Entity_Id := Empty; 7835 7836 begin 7837 if Ekind (P) = E_Package and then not In_Open_Scopes (P) then 7838 Priv_Id := First_Private_Entity (P); 7839 end if; 7840 7841 if P = Standard_Standard then 7842 Change_Selected_Component_To_Expanded_Name (N); 7843 Rewrite (N, Selector_Name (N)); 7844 Analyze (N); 7845 Set_Etype (Original_Node (N), Standard_Character); 7846 return True; 7847 end if; 7848 7849 Id := First_Entity (P); 7850 while Present (Id) and then Id /= Priv_Id loop 7851 if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then 7852 7853 -- We replace the node with the literal itself, resolve as a 7854 -- character, and set the type correctly. 7855 7856 if not Found then 7857 Change_Selected_Component_To_Expanded_Name (N); 7858 Rewrite (N, Selector_Name (N)); 7859 Analyze (N); 7860 Set_Etype (N, Id); 7861 Set_Etype (Original_Node (N), Id); 7862 Found := True; 7863 7864 else 7865 -- More than one type derived from Character in given scope. 7866 -- Collect all possible interpretations. 7867 7868 Add_One_Interp (N, Id, Id); 7869 end if; 7870 end if; 7871 7872 Next_Entity (Id); 7873 end loop; 7874 7875 return Found; 7876 end Has_Implicit_Character_Literal; 7877 7878 ---------------------- 7879 -- Has_Private_With -- 7880 ---------------------- 7881 7882 function Has_Private_With (E : Entity_Id) return Boolean is 7883 Comp_Unit : constant Node_Id := Cunit (Current_Sem_Unit); 7884 Item : Node_Id; 7885 7886 begin 7887 Item := First (Context_Items (Comp_Unit)); 7888 while Present (Item) loop 7889 if Nkind (Item) = N_With_Clause 7890 and then Private_Present (Item) 7891 and then Entity (Name (Item)) = E 7892 then 7893 return True; 7894 end if; 7895 7896 Next (Item); 7897 end loop; 7898 7899 return False; 7900 end Has_Private_With; 7901 7902 --------------------------- 7903 -- Has_Implicit_Operator -- 7904 --------------------------- 7905 7906 function Has_Implicit_Operator (N : Node_Id) return Boolean is 7907 Op_Id : constant Name_Id := Chars (Selector_Name (N)); 7908 P : constant Entity_Id := Entity (Prefix (N)); 7909 Id : Entity_Id; 7910 Priv_Id : Entity_Id := Empty; 7911 7912 procedure Add_Implicit_Operator 7913 (T : Entity_Id; 7914 Op_Type : Entity_Id := Empty); 7915 -- Add implicit interpretation to node N, using the type for which a 7916 -- predefined operator exists. If the operator yields a boolean type, 7917 -- the Operand_Type is implicitly referenced by the operator, and a 7918 -- reference to it must be generated. 7919 7920 --------------------------- 7921 -- Add_Implicit_Operator -- 7922 --------------------------- 7923 7924 procedure Add_Implicit_Operator 7925 (T : Entity_Id; 7926 Op_Type : Entity_Id := Empty) 7927 is 7928 Predef_Op : Entity_Id; 7929 7930 begin 7931 Predef_Op := Current_Entity (Selector_Name (N)); 7932 while Present (Predef_Op) 7933 and then Scope (Predef_Op) /= Standard_Standard 7934 loop 7935 Predef_Op := Homonym (Predef_Op); 7936 end loop; 7937 7938 if Nkind (N) = N_Selected_Component then 7939 Change_Selected_Component_To_Expanded_Name (N); 7940 end if; 7941 7942 -- If the context is an unanalyzed function call, determine whether 7943 -- a binary or unary interpretation is required. 7944 7945 if Nkind (Parent (N)) = N_Indexed_Component then 7946 declare 7947 Is_Binary_Call : constant Boolean := 7948 Present 7949 (Next (First (Expressions (Parent (N))))); 7950 Is_Binary_Op : constant Boolean := 7951 First_Entity 7952 (Predef_Op) /= Last_Entity (Predef_Op); 7953 Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); 7954 7955 begin 7956 if Is_Binary_Call then 7957 if Is_Binary_Op then 7958 Add_One_Interp (N, Predef_Op, T); 7959 else 7960 Add_One_Interp (N, Predef_Op2, T); 7961 end if; 7962 7963 else 7964 if not Is_Binary_Op then 7965 Add_One_Interp (N, Predef_Op, T); 7966 else 7967 Add_One_Interp (N, Predef_Op2, T); 7968 end if; 7969 end if; 7970 end; 7971 7972 else 7973 Add_One_Interp (N, Predef_Op, T); 7974 7975 -- For operators with unary and binary interpretations, if 7976 -- context is not a call, add both 7977 7978 if Present (Homonym (Predef_Op)) then 7979 Add_One_Interp (N, Homonym (Predef_Op), T); 7980 end if; 7981 end if; 7982 7983 -- The node is a reference to a predefined operator, and 7984 -- an implicit reference to the type of its operands. 7985 7986 if Present (Op_Type) then 7987 Generate_Operator_Reference (N, Op_Type); 7988 else 7989 Generate_Operator_Reference (N, T); 7990 end if; 7991 end Add_Implicit_Operator; 7992 7993 -- Start of processing for Has_Implicit_Operator 7994 7995 begin 7996 if Ekind (P) = E_Package and then not In_Open_Scopes (P) then 7997 Priv_Id := First_Private_Entity (P); 7998 end if; 7999 8000 Id := First_Entity (P); 8001 8002 case Op_Id is 8003 8004 -- Boolean operators: an implicit declaration exists if the scope 8005 -- contains a declaration for a derived Boolean type, or for an 8006 -- array of Boolean type. 8007 8008 when Name_Op_And 8009 | Name_Op_Not 8010 | Name_Op_Or 8011 | Name_Op_Xor 8012 => 8013 while Id /= Priv_Id loop 8014 if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then 8015 Add_Implicit_Operator (Id); 8016 return True; 8017 end if; 8018 8019 Next_Entity (Id); 8020 end loop; 8021 8022 -- Equality: look for any non-limited type (result is Boolean) 8023 8024 when Name_Op_Eq 8025 | Name_Op_Ne 8026 => 8027 while Id /= Priv_Id loop 8028 if Is_Type (Id) 8029 and then not Is_Limited_Type (Id) 8030 and then Is_Base_Type (Id) 8031 then 8032 Add_Implicit_Operator (Standard_Boolean, Id); 8033 return True; 8034 end if; 8035 8036 Next_Entity (Id); 8037 end loop; 8038 8039 -- Comparison operators: scalar type, or array of scalar 8040 8041 when Name_Op_Ge 8042 | Name_Op_Gt 8043 | Name_Op_Le 8044 | Name_Op_Lt 8045 => 8046 while Id /= Priv_Id loop 8047 if (Is_Scalar_Type (Id) 8048 or else (Is_Array_Type (Id) 8049 and then Is_Scalar_Type (Component_Type (Id)))) 8050 and then Is_Base_Type (Id) 8051 then 8052 Add_Implicit_Operator (Standard_Boolean, Id); 8053 return True; 8054 end if; 8055 8056 Next_Entity (Id); 8057 end loop; 8058 8059 -- Arithmetic operators: any numeric type 8060 8061 when Name_Op_Abs 8062 | Name_Op_Add 8063 | Name_Op_Divide 8064 | Name_Op_Expon 8065 | Name_Op_Mod 8066 | Name_Op_Multiply 8067 | Name_Op_Rem 8068 | Name_Op_Subtract 8069 => 8070 while Id /= Priv_Id loop 8071 if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then 8072 Add_Implicit_Operator (Id); 8073 return True; 8074 end if; 8075 8076 Next_Entity (Id); 8077 end loop; 8078 8079 -- Concatenation: any one-dimensional array type 8080 8081 when Name_Op_Concat => 8082 while Id /= Priv_Id loop 8083 if Is_Array_Type (Id) 8084 and then Number_Dimensions (Id) = 1 8085 and then Is_Base_Type (Id) 8086 then 8087 Add_Implicit_Operator (Id); 8088 return True; 8089 end if; 8090 8091 Next_Entity (Id); 8092 end loop; 8093 8094 -- What is the others condition here? Should we be using a 8095 -- subtype of Name_Id that would restrict to operators ??? 8096 8097 when others => 8098 null; 8099 end case; 8100 8101 -- If we fall through, then we do not have an implicit operator 8102 8103 return False; 8104 end Has_Implicit_Operator; 8105 8106 ----------------------------------- 8107 -- Has_Loop_In_Inner_Open_Scopes -- 8108 ----------------------------------- 8109 8110 function Has_Loop_In_Inner_Open_Scopes (S : Entity_Id) return Boolean is 8111 begin 8112 -- Several scope stacks are maintained by Scope_Stack. The base of the 8113 -- currently active scope stack is denoted by the Is_Active_Stack_Base 8114 -- flag in the scope stack entry. Note that the scope stacks used to 8115 -- simply be delimited implicitly by the presence of Standard_Standard 8116 -- at their base, but there now are cases where this is not sufficient 8117 -- because Standard_Standard actually may appear in the middle of the 8118 -- active set of scopes. 8119 8120 for J in reverse 0 .. Scope_Stack.Last loop 8121 8122 -- S was reached without seing a loop scope first 8123 8124 if Scope_Stack.Table (J).Entity = S then 8125 return False; 8126 8127 -- S was not yet reached, so it contains at least one inner loop 8128 8129 elsif Ekind (Scope_Stack.Table (J).Entity) = E_Loop then 8130 return True; 8131 end if; 8132 8133 -- Check Is_Active_Stack_Base to tell us when to stop, as there are 8134 -- cases where Standard_Standard appears in the middle of the active 8135 -- set of scopes. This affects the declaration and overriding of 8136 -- private inherited operations in instantiations of generic child 8137 -- units. 8138 8139 pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base); 8140 end loop; 8141 8142 raise Program_Error; -- unreachable 8143 end Has_Loop_In_Inner_Open_Scopes; 8144 8145 -------------------- 8146 -- In_Open_Scopes -- 8147 -------------------- 8148 8149 function In_Open_Scopes (S : Entity_Id) return Boolean is 8150 begin 8151 -- Several scope stacks are maintained by Scope_Stack. The base of the 8152 -- currently active scope stack is denoted by the Is_Active_Stack_Base 8153 -- flag in the scope stack entry. Note that the scope stacks used to 8154 -- simply be delimited implicitly by the presence of Standard_Standard 8155 -- at their base, but there now are cases where this is not sufficient 8156 -- because Standard_Standard actually may appear in the middle of the 8157 -- active set of scopes. 8158 8159 for J in reverse 0 .. Scope_Stack.Last loop 8160 if Scope_Stack.Table (J).Entity = S then 8161 return True; 8162 end if; 8163 8164 -- Check Is_Active_Stack_Base to tell us when to stop, as there are 8165 -- cases where Standard_Standard appears in the middle of the active 8166 -- set of scopes. This affects the declaration and overriding of 8167 -- private inherited operations in instantiations of generic child 8168 -- units. 8169 8170 exit when Scope_Stack.Table (J).Is_Active_Stack_Base; 8171 end loop; 8172 8173 return False; 8174 end In_Open_Scopes; 8175 8176 ----------------------------- 8177 -- Inherit_Renamed_Profile -- 8178 ----------------------------- 8179 8180 procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is 8181 New_F : Entity_Id; 8182 Old_F : Entity_Id; 8183 Old_T : Entity_Id; 8184 New_T : Entity_Id; 8185 8186 begin 8187 if Ekind (Old_S) = E_Operator then 8188 New_F := First_Formal (New_S); 8189 8190 while Present (New_F) loop 8191 Set_Etype (New_F, Base_Type (Etype (New_F))); 8192 Next_Formal (New_F); 8193 end loop; 8194 8195 Set_Etype (New_S, Base_Type (Etype (New_S))); 8196 8197 else 8198 New_F := First_Formal (New_S); 8199 Old_F := First_Formal (Old_S); 8200 8201 while Present (New_F) loop 8202 New_T := Etype (New_F); 8203 Old_T := Etype (Old_F); 8204 8205 -- If the new type is a renaming of the old one, as is the case 8206 -- for actuals in instances, retain its name, to simplify later 8207 -- disambiguation. 8208 8209 if Nkind (Parent (New_T)) = N_Subtype_Declaration 8210 and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) 8211 and then Entity (Subtype_Indication (Parent (New_T))) = Old_T 8212 then 8213 null; 8214 else 8215 Set_Etype (New_F, Old_T); 8216 end if; 8217 8218 Next_Formal (New_F); 8219 Next_Formal (Old_F); 8220 end loop; 8221 8222 pragma Assert (No (Old_F)); 8223 8224 if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then 8225 Set_Etype (New_S, Etype (Old_S)); 8226 end if; 8227 end if; 8228 end Inherit_Renamed_Profile; 8229 8230 ---------------- 8231 -- Initialize -- 8232 ---------------- 8233 8234 procedure Initialize is 8235 begin 8236 Urefs.Init; 8237 end Initialize; 8238 8239 ------------------------- 8240 -- Install_Use_Clauses -- 8241 ------------------------- 8242 8243 procedure Install_Use_Clauses 8244 (Clause : Node_Id; 8245 Force_Installation : Boolean := False) 8246 is 8247 U : Node_Id; 8248 8249 begin 8250 U := Clause; 8251 while Present (U) loop 8252 8253 -- Case of USE package 8254 8255 if Nkind (U) = N_Use_Package_Clause then 8256 Use_One_Package (U, Name (U), True); 8257 8258 -- Case of USE TYPE 8259 8260 else 8261 Use_One_Type (Subtype_Mark (U), Force => Force_Installation); 8262 8263 end if; 8264 8265 Next_Use_Clause (U); 8266 end loop; 8267 end Install_Use_Clauses; 8268 8269 ------------------------------------- 8270 -- Is_Appropriate_For_Entry_Prefix -- 8271 ------------------------------------- 8272 8273 function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is 8274 P_Type : Entity_Id := T; 8275 8276 begin 8277 if Is_Access_Type (P_Type) then 8278 P_Type := Designated_Type (P_Type); 8279 end if; 8280 8281 return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); 8282 end Is_Appropriate_For_Entry_Prefix; 8283 8284 ------------------------------- 8285 -- Is_Appropriate_For_Record -- 8286 ------------------------------- 8287 8288 function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is 8289 8290 function Has_Components (T1 : Entity_Id) return Boolean; 8291 -- Determine if given type has components (i.e. is either a record 8292 -- type or a type that has discriminants). 8293 8294 -------------------- 8295 -- Has_Components -- 8296 -------------------- 8297 8298 function Has_Components (T1 : Entity_Id) return Boolean is 8299 begin 8300 return Is_Record_Type (T1) 8301 or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) 8302 or else (Is_Task_Type (T1) and then Has_Discriminants (T1)) 8303 or else (Is_Incomplete_Type (T1) 8304 and then From_Limited_With (T1) 8305 and then Present (Non_Limited_View (T1)) 8306 and then Is_Record_Type 8307 (Get_Full_View (Non_Limited_View (T1)))); 8308 end Has_Components; 8309 8310 -- Start of processing for Is_Appropriate_For_Record 8311 8312 begin 8313 return 8314 Present (T) 8315 and then (Has_Components (T) 8316 or else (Is_Access_Type (T) 8317 and then Has_Components (Designated_Type (T)))); 8318 end Is_Appropriate_For_Record; 8319 8320 ---------------------- 8321 -- Mark_Use_Clauses -- 8322 ---------------------- 8323 8324 procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is 8325 procedure Mark_Parameters (Call : Entity_Id); 8326 -- Perform use_type_clause marking for all parameters in a subprogram 8327 -- or operator call. 8328 8329 procedure Mark_Use_Package (Pak : Entity_Id); 8330 -- Move up the Prev_Use_Clause chain for packages denoted by Pak - 8331 -- marking each clause in the chain as effective in the process. 8332 8333 procedure Mark_Use_Type (E : Entity_Id); 8334 -- Similar to Do_Use_Package_Marking except we move up the 8335 -- Prev_Use_Clause chain for the type denoted by E. 8336 8337 --------------------- 8338 -- Mark_Parameters -- 8339 --------------------- 8340 8341 procedure Mark_Parameters (Call : Entity_Id) is 8342 Curr : Node_Id; 8343 8344 begin 8345 -- Move through all of the formals 8346 8347 Curr := First_Formal (Call); 8348 while Present (Curr) loop 8349 Mark_Use_Type (Curr); 8350 8351 Curr := Next_Formal (Curr); 8352 end loop; 8353 8354 -- Handle the return type 8355 8356 Mark_Use_Type (Call); 8357 end Mark_Parameters; 8358 8359 ---------------------- 8360 -- Mark_Use_Package -- 8361 ---------------------- 8362 8363 procedure Mark_Use_Package (Pak : Entity_Id) is 8364 Curr : Node_Id; 8365 8366 begin 8367 -- Ignore cases where the scope of the type is not a package (e.g. 8368 -- Standard_Standard). 8369 8370 if Ekind (Pak) /= E_Package then 8371 return; 8372 end if; 8373 8374 Curr := Current_Use_Clause (Pak); 8375 while Present (Curr) 8376 and then not Is_Effective_Use_Clause (Curr) 8377 loop 8378 -- We need to mark the previous use clauses as effective, but 8379 -- each use clause may in turn render other use_package_clauses 8380 -- effective. Additionally, it is possible to have a parent 8381 -- package renamed as a child of itself so we must check the 8382 -- prefix entity is not the same as the package we are marking. 8383 8384 if Nkind (Name (Curr)) /= N_Identifier 8385 and then Present (Prefix (Name (Curr))) 8386 and then Entity (Prefix (Name (Curr))) /= Pak 8387 then 8388 Mark_Use_Package (Entity (Prefix (Name (Curr)))); 8389 8390 -- It is also possible to have a child package without a prefix 8391 -- that relies on a previous use_package_clause. 8392 8393 elsif Nkind (Name (Curr)) = N_Identifier 8394 and then Is_Child_Unit (Entity (Name (Curr))) 8395 then 8396 Mark_Use_Package (Scope (Entity (Name (Curr)))); 8397 end if; 8398 8399 -- Mark the use_package_clause as effective and move up the chain 8400 8401 Set_Is_Effective_Use_Clause (Curr); 8402 8403 Curr := Prev_Use_Clause (Curr); 8404 end loop; 8405 end Mark_Use_Package; 8406 8407 ------------------- 8408 -- Mark_Use_Type -- 8409 ------------------- 8410 8411 procedure Mark_Use_Type (E : Entity_Id) is 8412 Curr : Node_Id; 8413 Base : Entity_Id; 8414 8415 begin 8416 -- Ignore void types and unresolved string literals and primitives 8417 8418 if Nkind (E) = N_String_Literal 8419 or else Nkind (Etype (E)) not in N_Entity 8420 or else not Is_Type (Etype (E)) 8421 then 8422 return; 8423 end if; 8424 8425 -- Primitives with class-wide operands might additionally render 8426 -- their base type's use_clauses effective - so do a recursive check 8427 -- here. 8428 8429 Base := Base_Type (Etype (E)); 8430 8431 if Ekind (Base) = E_Class_Wide_Type then 8432 Mark_Use_Type (Base); 8433 end if; 8434 8435 -- The package containing the type or operator function being used 8436 -- may be in use as well, so mark any use_package_clauses for it as 8437 -- effective. There are also additional sanity checks performed here 8438 -- for ignoring previous errors. 8439 8440 Mark_Use_Package (Scope (Base)); 8441 8442 if Nkind (E) in N_Op 8443 and then Present (Entity (E)) 8444 and then Present (Scope (Entity (E))) 8445 then 8446 Mark_Use_Package (Scope (Entity (E))); 8447 end if; 8448 8449 Curr := Current_Use_Clause (Base); 8450 while Present (Curr) 8451 and then not Is_Effective_Use_Clause (Curr) 8452 loop 8453 -- Current use_type_clause may render other use_package_clauses 8454 -- effective. 8455 8456 if Nkind (Subtype_Mark (Curr)) /= N_Identifier 8457 and then Present (Prefix (Subtype_Mark (Curr))) 8458 then 8459 Mark_Use_Package (Entity (Prefix (Subtype_Mark (Curr)))); 8460 end if; 8461 8462 -- Mark the use_type_clause as effective and move up the chain 8463 8464 Set_Is_Effective_Use_Clause (Curr); 8465 8466 Curr := Prev_Use_Clause (Curr); 8467 end loop; 8468 end Mark_Use_Type; 8469 8470 -- Start of processing for Mark_Use_Clauses 8471 8472 begin 8473 -- Use clauses in and of themselves do not count as a "use" of a 8474 -- package. 8475 8476 if Nkind_In (Parent (Id), N_Use_Package_Clause, N_Use_Type_Clause) then 8477 return; 8478 end if; 8479 8480 -- Handle entities 8481 8482 if Nkind (Id) in N_Entity then 8483 8484 -- Mark the entity's package 8485 8486 if Is_Potentially_Use_Visible (Id) then 8487 Mark_Use_Package (Scope (Id)); 8488 end if; 8489 8490 -- Mark enumeration literals 8491 8492 if Ekind (Id) = E_Enumeration_Literal then 8493 Mark_Use_Type (Id); 8494 8495 -- Mark primitives 8496 8497 elsif (Ekind (Id) in Overloadable_Kind 8498 or else Ekind_In (Id, E_Generic_Function, 8499 E_Generic_Procedure)) 8500 and then (Is_Potentially_Use_Visible (Id) 8501 or else Is_Intrinsic_Subprogram (Id) 8502 or else (Ekind_In (Id, E_Function, E_Procedure) 8503 and then Is_Generic_Actual_Subprogram (Id))) 8504 then 8505 Mark_Parameters (Id); 8506 end if; 8507 8508 -- Handle nodes 8509 8510 else 8511 -- Mark operators 8512 8513 if Nkind (Id) in N_Op then 8514 8515 -- At this point the left operand may not be resolved if we are 8516 -- encountering multiple operators next to eachother in an 8517 -- expression. 8518 8519 if Nkind (Id) in N_Binary_Op 8520 and then not (Nkind (Left_Opnd (Id)) in N_Op) 8521 then 8522 Mark_Use_Type (Left_Opnd (Id)); 8523 end if; 8524 8525 Mark_Use_Type (Right_Opnd (Id)); 8526 Mark_Use_Type (Id); 8527 8528 -- Mark entity identifiers 8529 8530 elsif Nkind (Id) in N_Has_Entity 8531 and then (Is_Potentially_Use_Visible (Entity (Id)) 8532 or else (Is_Generic_Instance (Entity (Id)) 8533 and then Is_Immediately_Visible (Entity (Id)))) 8534 then 8535 -- Ignore fully qualified names as they do not count as a "use" of 8536 -- a package. 8537 8538 if Nkind_In (Id, N_Identifier, N_Operator_Symbol) 8539 or else (Present (Prefix (Id)) 8540 and then Scope (Entity (Id)) /= Entity (Prefix (Id))) 8541 then 8542 Mark_Use_Clauses (Entity (Id)); 8543 end if; 8544 end if; 8545 end if; 8546 end Mark_Use_Clauses; 8547 8548 -------------------------------- 8549 -- Most_Descendant_Use_Clause -- 8550 -------------------------------- 8551 8552 function Most_Descendant_Use_Clause 8553 (Clause1 : Entity_Id; 8554 Clause2 : Entity_Id) return Entity_Id 8555 is 8556 Scope1 : Entity_Id; 8557 Scope2 : Entity_Id; 8558 8559 begin 8560 if Clause1 = Clause2 then 8561 return Clause1; 8562 end if; 8563 8564 -- We determine which one is the most descendant by the scope distance 8565 -- to the ultimate parent unit. 8566 8567 Scope1 := Entity_Of_Unit (Unit (Parent (Clause1))); 8568 Scope2 := Entity_Of_Unit (Unit (Parent (Clause2))); 8569 while Scope1 /= Standard_Standard 8570 and then Scope2 /= Standard_Standard 8571 loop 8572 Scope1 := Scope (Scope1); 8573 Scope2 := Scope (Scope2); 8574 8575 if not Present (Scope1) then 8576 return Clause1; 8577 elsif not Present (Scope2) then 8578 return Clause2; 8579 end if; 8580 end loop; 8581 8582 if Scope1 = Standard_Standard then 8583 return Clause1; 8584 end if; 8585 8586 return Clause2; 8587 end Most_Descendant_Use_Clause; 8588 8589 --------------- 8590 -- Pop_Scope -- 8591 --------------- 8592 8593 procedure Pop_Scope is 8594 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 8595 S : constant Entity_Id := SST.Entity; 8596 8597 begin 8598 if Debug_Flag_E then 8599 Write_Info; 8600 end if; 8601 8602 -- Set Default_Storage_Pool field of the library unit if necessary 8603 8604 if Ekind_In (S, E_Package, E_Generic_Package) 8605 and then 8606 Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit 8607 then 8608 declare 8609 Aux : constant Node_Id := 8610 Aux_Decls_Node (Parent (Unit_Declaration_Node (S))); 8611 begin 8612 if No (Default_Storage_Pool (Aux)) then 8613 Set_Default_Storage_Pool (Aux, Default_Pool); 8614 end if; 8615 end; 8616 end if; 8617 8618 Scope_Suppress := SST.Save_Scope_Suppress; 8619 Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; 8620 Check_Policy_List := SST.Save_Check_Policy_List; 8621 Default_Pool := SST.Save_Default_Storage_Pool; 8622 No_Tagged_Streams := SST.Save_No_Tagged_Streams; 8623 SPARK_Mode := SST.Save_SPARK_Mode; 8624 SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma; 8625 Default_SSO := SST.Save_Default_SSO; 8626 Uneval_Old := SST.Save_Uneval_Old; 8627 8628 if Debug_Flag_W then 8629 Write_Str ("<-- exiting scope: "); 8630 Write_Name (Chars (Current_Scope)); 8631 Write_Str (", Depth="); 8632 Write_Int (Int (Scope_Stack.Last)); 8633 Write_Eol; 8634 end if; 8635 8636 End_Use_Clauses (SST.First_Use_Clause); 8637 8638 -- If the actions to be wrapped are still there they will get lost 8639 -- causing incomplete code to be generated. It is better to abort in 8640 -- this case (and we do the abort even with assertions off since the 8641 -- penalty is incorrect code generation). 8642 8643 if SST.Actions_To_Be_Wrapped /= Scope_Actions'(others => No_List) then 8644 raise Program_Error; 8645 end if; 8646 8647 -- Free last subprogram name if allocated, and pop scope 8648 8649 Free (SST.Last_Subprogram_Name); 8650 Scope_Stack.Decrement_Last; 8651 end Pop_Scope; 8652 8653 ---------------- 8654 -- Push_Scope -- 8655 ---------------- 8656 8657 procedure Push_Scope (S : Entity_Id) is 8658 E : constant Entity_Id := Scope (S); 8659 8660 begin 8661 if Ekind (S) = E_Void then 8662 null; 8663 8664 -- Set scope depth if not a non-concurrent type, and we have not yet set 8665 -- the scope depth. This means that we have the first occurrence of the 8666 -- scope, and this is where the depth is set. 8667 8668 elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) 8669 and then not Scope_Depth_Set (S) 8670 then 8671 if S = Standard_Standard then 8672 Set_Scope_Depth_Value (S, Uint_0); 8673 8674 elsif Is_Child_Unit (S) then 8675 Set_Scope_Depth_Value (S, Uint_1); 8676 8677 elsif not Is_Record_Type (Current_Scope) then 8678 if Ekind (S) = E_Loop then 8679 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); 8680 else 8681 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); 8682 end if; 8683 end if; 8684 end if; 8685 8686 Scope_Stack.Increment_Last; 8687 8688 declare 8689 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 8690 8691 begin 8692 SST.Entity := S; 8693 SST.Save_Scope_Suppress := Scope_Suppress; 8694 SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; 8695 SST.Save_Check_Policy_List := Check_Policy_List; 8696 SST.Save_Default_Storage_Pool := Default_Pool; 8697 SST.Save_No_Tagged_Streams := No_Tagged_Streams; 8698 SST.Save_SPARK_Mode := SPARK_Mode; 8699 SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma; 8700 SST.Save_Default_SSO := Default_SSO; 8701 SST.Save_Uneval_Old := Uneval_Old; 8702 8703 -- Each new scope pushed onto the scope stack inherits the component 8704 -- alignment of the previous scope. This emulates the "visibility" 8705 -- semantics of pragma Component_Alignment. 8706 8707 if Scope_Stack.Last > Scope_Stack.First then 8708 SST.Component_Alignment_Default := 8709 Scope_Stack.Table 8710 (Scope_Stack.Last - 1). Component_Alignment_Default; 8711 8712 -- Otherwise, this is the first scope being pushed on the scope 8713 -- stack. Inherit the component alignment from the configuration 8714 -- form of pragma Component_Alignment (if any). 8715 8716 else 8717 SST.Component_Alignment_Default := 8718 Configuration_Component_Alignment; 8719 end if; 8720 8721 SST.Last_Subprogram_Name := null; 8722 SST.Is_Transient := False; 8723 SST.Node_To_Be_Wrapped := Empty; 8724 SST.Pending_Freeze_Actions := No_List; 8725 SST.Actions_To_Be_Wrapped := (others => No_List); 8726 SST.First_Use_Clause := Empty; 8727 SST.Is_Active_Stack_Base := False; 8728 SST.Previous_Visibility := False; 8729 SST.Locked_Shared_Objects := No_Elist; 8730 end; 8731 8732 if Debug_Flag_W then 8733 Write_Str ("--> new scope: "); 8734 Write_Name (Chars (Current_Scope)); 8735 Write_Str (", Id="); 8736 Write_Int (Int (Current_Scope)); 8737 Write_Str (", Depth="); 8738 Write_Int (Int (Scope_Stack.Last)); 8739 Write_Eol; 8740 end if; 8741 8742 -- Deal with copying flags from the previous scope to this one. This is 8743 -- not necessary if either scope is standard, or if the new scope is a 8744 -- child unit. 8745 8746 if S /= Standard_Standard 8747 and then Scope (S) /= Standard_Standard 8748 and then not Is_Child_Unit (S) 8749 then 8750 if Nkind (E) not in N_Entity then 8751 return; 8752 end if; 8753 8754 -- Copy categorization flags from Scope (S) to S, this is not done 8755 -- when Scope (S) is Standard_Standard since propagation is from 8756 -- library unit entity inwards. Copy other relevant attributes as 8757 -- well (Discard_Names in particular). 8758 8759 -- We only propagate inwards for library level entities, 8760 -- inner level subprograms do not inherit the categorization. 8761 8762 if Is_Library_Level_Entity (S) then 8763 Set_Is_Preelaborated (S, Is_Preelaborated (E)); 8764 Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); 8765 Set_Discard_Names (S, Discard_Names (E)); 8766 Set_Suppress_Value_Tracking_On_Call 8767 (S, Suppress_Value_Tracking_On_Call (E)); 8768 Set_Categorization_From_Scope (E => S, Scop => E); 8769 end if; 8770 end if; 8771 8772 if Is_Child_Unit (S) 8773 and then Present (E) 8774 and then Ekind_In (E, E_Package, E_Generic_Package) 8775 and then 8776 Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit 8777 then 8778 declare 8779 Aux : constant Node_Id := 8780 Aux_Decls_Node (Parent (Unit_Declaration_Node (E))); 8781 begin 8782 if Present (Default_Storage_Pool (Aux)) then 8783 Default_Pool := Default_Storage_Pool (Aux); 8784 end if; 8785 end; 8786 end if; 8787 end Push_Scope; 8788 8789 --------------------- 8790 -- Premature_Usage -- 8791 --------------------- 8792 8793 procedure Premature_Usage (N : Node_Id) is 8794 Kind : constant Node_Kind := Nkind (Parent (Entity (N))); 8795 E : Entity_Id := Entity (N); 8796 8797 begin 8798 -- Within an instance, the analysis of the actual for a formal object 8799 -- does not see the name of the object itself. This is significant only 8800 -- if the object is an aggregate, where its analysis does not do any 8801 -- name resolution on component associations. (see 4717-008). In such a 8802 -- case, look for the visible homonym on the chain. 8803 8804 if In_Instance and then Present (Homonym (E)) then 8805 E := Homonym (E); 8806 while Present (E) and then not In_Open_Scopes (Scope (E)) loop 8807 E := Homonym (E); 8808 end loop; 8809 8810 if Present (E) then 8811 Set_Entity (N, E); 8812 Set_Etype (N, Etype (E)); 8813 return; 8814 end if; 8815 end if; 8816 8817 if Kind = N_Component_Declaration then 8818 Error_Msg_N 8819 ("component&! cannot be used before end of record declaration", N); 8820 8821 elsif Kind = N_Parameter_Specification then 8822 Error_Msg_N 8823 ("formal parameter&! cannot be used before end of specification", 8824 N); 8825 8826 elsif Kind = N_Discriminant_Specification then 8827 Error_Msg_N 8828 ("discriminant&! cannot be used before end of discriminant part", 8829 N); 8830 8831 elsif Kind = N_Procedure_Specification 8832 or else Kind = N_Function_Specification 8833 then 8834 Error_Msg_N 8835 ("subprogram&! cannot be used before end of its declaration", 8836 N); 8837 8838 elsif Kind = N_Full_Type_Declaration then 8839 Error_Msg_N 8840 ("type& cannot be used before end of its declaration!", N); 8841 8842 else 8843 Error_Msg_N 8844 ("object& cannot be used before end of its declaration!", N); 8845 8846 -- If the premature reference appears as the expression in its own 8847 -- declaration, rewrite it to prevent compiler loops in subsequent 8848 -- uses of this mangled declaration in address clauses. 8849 8850 if Nkind (Parent (N)) = N_Object_Declaration then 8851 Set_Entity (N, Any_Id); 8852 end if; 8853 end if; 8854 end Premature_Usage; 8855 8856 ------------------------ 8857 -- Present_System_Aux -- 8858 ------------------------ 8859 8860 function Present_System_Aux (N : Node_Id := Empty) return Boolean is 8861 Loc : Source_Ptr; 8862 Aux_Name : Unit_Name_Type; 8863 Unum : Unit_Number_Type; 8864 Withn : Node_Id; 8865 With_Sys : Node_Id; 8866 The_Unit : Node_Id; 8867 8868 function Find_System (C_Unit : Node_Id) return Entity_Id; 8869 -- Scan context clause of compilation unit to find with_clause 8870 -- for System. 8871 8872 ----------------- 8873 -- Find_System -- 8874 ----------------- 8875 8876 function Find_System (C_Unit : Node_Id) return Entity_Id is 8877 With_Clause : Node_Id; 8878 8879 begin 8880 With_Clause := First (Context_Items (C_Unit)); 8881 while Present (With_Clause) loop 8882 if (Nkind (With_Clause) = N_With_Clause 8883 and then Chars (Name (With_Clause)) = Name_System) 8884 and then Comes_From_Source (With_Clause) 8885 then 8886 return With_Clause; 8887 end if; 8888 8889 Next (With_Clause); 8890 end loop; 8891 8892 return Empty; 8893 end Find_System; 8894 8895 -- Start of processing for Present_System_Aux 8896 8897 begin 8898 -- The child unit may have been loaded and analyzed already 8899 8900 if Present (System_Aux_Id) then 8901 return True; 8902 8903 -- If no previous pragma for System.Aux, nothing to load 8904 8905 elsif No (System_Extend_Unit) then 8906 return False; 8907 8908 -- Use the unit name given in the pragma to retrieve the unit. 8909 -- Verify that System itself appears in the context clause of the 8910 -- current compilation. If System is not present, an error will 8911 -- have been reported already. 8912 8913 else 8914 With_Sys := Find_System (Cunit (Current_Sem_Unit)); 8915 8916 The_Unit := Unit (Cunit (Current_Sem_Unit)); 8917 8918 if No (With_Sys) 8919 and then 8920 (Nkind (The_Unit) = N_Package_Body 8921 or else (Nkind (The_Unit) = N_Subprogram_Body 8922 and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) 8923 then 8924 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); 8925 end if; 8926 8927 if No (With_Sys) and then Present (N) then 8928 8929 -- If we are compiling a subunit, we need to examine its 8930 -- context as well (Current_Sem_Unit is the parent unit); 8931 8932 The_Unit := Parent (N); 8933 while Nkind (The_Unit) /= N_Compilation_Unit loop 8934 The_Unit := Parent (The_Unit); 8935 end loop; 8936 8937 if Nkind (Unit (The_Unit)) = N_Subunit then 8938 With_Sys := Find_System (The_Unit); 8939 end if; 8940 end if; 8941 8942 if No (With_Sys) then 8943 return False; 8944 end if; 8945 8946 Loc := Sloc (With_Sys); 8947 Get_Name_String (Chars (Expression (System_Extend_Unit))); 8948 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); 8949 Name_Buffer (1 .. 7) := "system."; 8950 Name_Buffer (Name_Len + 8) := '%'; 8951 Name_Buffer (Name_Len + 9) := 's'; 8952 Name_Len := Name_Len + 9; 8953 Aux_Name := Name_Find; 8954 8955 Unum := 8956 Load_Unit 8957 (Load_Name => Aux_Name, 8958 Required => False, 8959 Subunit => False, 8960 Error_Node => With_Sys); 8961 8962 if Unum /= No_Unit then 8963 Semantics (Cunit (Unum)); 8964 System_Aux_Id := 8965 Defining_Entity (Specification (Unit (Cunit (Unum)))); 8966 8967 Withn := 8968 Make_With_Clause (Loc, 8969 Name => 8970 Make_Expanded_Name (Loc, 8971 Chars => Chars (System_Aux_Id), 8972 Prefix => 8973 New_Occurrence_Of (Scope (System_Aux_Id), Loc), 8974 Selector_Name => New_Occurrence_Of (System_Aux_Id, Loc))); 8975 8976 Set_Entity (Name (Withn), System_Aux_Id); 8977 8978 Set_Corresponding_Spec (Withn, System_Aux_Id); 8979 Set_First_Name (Withn); 8980 Set_Implicit_With (Withn); 8981 Set_Library_Unit (Withn, Cunit (Unum)); 8982 8983 Insert_After (With_Sys, Withn); 8984 Mark_Rewrite_Insertion (Withn); 8985 Set_Context_Installed (Withn); 8986 8987 return True; 8988 8989 -- Here if unit load failed 8990 8991 else 8992 Error_Msg_Name_1 := Name_System; 8993 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit)); 8994 Error_Msg_N 8995 ("extension package `%.%` does not exist", 8996 Opt.System_Extend_Unit); 8997 return False; 8998 end if; 8999 end if; 9000 end Present_System_Aux; 9001 9002 ------------------------- 9003 -- Restore_Scope_Stack -- 9004 ------------------------- 9005 9006 procedure Restore_Scope_Stack 9007 (List : Elist_Id; 9008 Handle_Use : Boolean := True) 9009 is 9010 SS_Last : constant Int := Scope_Stack.Last; 9011 Elmt : Elmt_Id; 9012 9013 begin 9014 -- Restore visibility of previous scope stack, if any, using the list 9015 -- we saved (we use Remove, since this list will not be used again). 9016 9017 loop 9018 Elmt := Last_Elmt (List); 9019 exit when Elmt = No_Elmt; 9020 Set_Is_Immediately_Visible (Node (Elmt)); 9021 Remove_Last_Elmt (List); 9022 end loop; 9023 9024 -- Restore use clauses 9025 9026 if SS_Last >= Scope_Stack.First 9027 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 9028 and then Handle_Use 9029 then 9030 Install_Use_Clauses 9031 (Scope_Stack.Table (SS_Last).First_Use_Clause, 9032 Force_Installation => True); 9033 end if; 9034 end Restore_Scope_Stack; 9035 9036 ---------------------- 9037 -- Save_Scope_Stack -- 9038 ---------------------- 9039 9040 -- Save_Scope_Stack/Restore_Scope_Stack were originally designed to avoid 9041 -- consuming any memory. That is, Save_Scope_Stack took care of removing 9042 -- from immediate visibility entities and Restore_Scope_Stack took care 9043 -- of restoring their visibility analyzing the context of each entity. The 9044 -- problem of such approach is that it was fragile and caused unexpected 9045 -- visibility problems, and indeed one test was found where there was a 9046 -- real problem. 9047 9048 -- Furthermore, the following experiment was carried out: 9049 9050 -- - Save_Scope_Stack was modified to store in an Elist1 all those 9051 -- entities whose attribute Is_Immediately_Visible is modified 9052 -- from True to False. 9053 9054 -- - Restore_Scope_Stack was modified to store in another Elist2 9055 -- all the entities whose attribute Is_Immediately_Visible is 9056 -- modified from False to True. 9057 9058 -- - Extra code was added to verify that all the elements of Elist1 9059 -- are found in Elist2 9060 9061 -- This test shows that there may be more occurrences of this problem which 9062 -- have not yet been detected. As a result, we replaced that approach by 9063 -- the current one in which Save_Scope_Stack returns the list of entities 9064 -- whose visibility is changed, and that list is passed to Restore_Scope_ 9065 -- Stack to undo that change. This approach is simpler and safer, although 9066 -- it consumes more memory. 9067 9068 function Save_Scope_Stack (Handle_Use : Boolean := True) return Elist_Id is 9069 Result : constant Elist_Id := New_Elmt_List; 9070 E : Entity_Id; 9071 S : Entity_Id; 9072 SS_Last : constant Int := Scope_Stack.Last; 9073 9074 procedure Remove_From_Visibility (E : Entity_Id); 9075 -- If E is immediately visible then append it to the result and remove 9076 -- it temporarily from visibility. 9077 9078 ---------------------------- 9079 -- Remove_From_Visibility -- 9080 ---------------------------- 9081 9082 procedure Remove_From_Visibility (E : Entity_Id) is 9083 begin 9084 if Is_Immediately_Visible (E) then 9085 Append_Elmt (E, Result); 9086 Set_Is_Immediately_Visible (E, False); 9087 end if; 9088 end Remove_From_Visibility; 9089 9090 -- Start of processing for Save_Scope_Stack 9091 9092 begin 9093 if SS_Last >= Scope_Stack.First 9094 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 9095 then 9096 if Handle_Use then 9097 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); 9098 end if; 9099 9100 -- If the call is from within a compilation unit, as when called from 9101 -- Rtsfind, make current entries in scope stack invisible while we 9102 -- analyze the new unit. 9103 9104 for J in reverse 0 .. SS_Last loop 9105 exit when Scope_Stack.Table (J).Entity = Standard_Standard 9106 or else No (Scope_Stack.Table (J).Entity); 9107 9108 S := Scope_Stack.Table (J).Entity; 9109 9110 Remove_From_Visibility (S); 9111 9112 E := First_Entity (S); 9113 while Present (E) loop 9114 Remove_From_Visibility (E); 9115 Next_Entity (E); 9116 end loop; 9117 end loop; 9118 9119 end if; 9120 9121 return Result; 9122 end Save_Scope_Stack; 9123 9124 ------------- 9125 -- Set_Use -- 9126 ------------- 9127 9128 procedure Set_Use (L : List_Id) is 9129 Decl : Node_Id; 9130 9131 begin 9132 if Present (L) then 9133 Decl := First (L); 9134 while Present (Decl) loop 9135 if Nkind (Decl) = N_Use_Package_Clause then 9136 Chain_Use_Clause (Decl); 9137 Use_One_Package (Decl, Name (Decl)); 9138 9139 elsif Nkind (Decl) = N_Use_Type_Clause then 9140 Chain_Use_Clause (Decl); 9141 Use_One_Type (Subtype_Mark (Decl)); 9142 9143 end if; 9144 9145 Next (Decl); 9146 end loop; 9147 end if; 9148 end Set_Use; 9149 9150 ----------------------------- 9151 -- Update_Use_Clause_Chain -- 9152 ----------------------------- 9153 9154 procedure Update_Use_Clause_Chain is 9155 9156 procedure Update_Chain_In_Scope (Level : Int); 9157 -- Iterate through one level in the scope stack verifying each use-type 9158 -- clause within said level is used then reset the Current_Use_Clause 9159 -- to a redundant use clause outside of the current ending scope if such 9160 -- a clause exists. 9161 9162 --------------------------- 9163 -- Update_Chain_In_Scope -- 9164 --------------------------- 9165 9166 procedure Update_Chain_In_Scope (Level : Int) is 9167 Curr : Node_Id; 9168 N : Node_Id; 9169 9170 begin 9171 -- Loop through all use clauses within the scope dictated by Level 9172 9173 Curr := Scope_Stack.Table (Level).First_Use_Clause; 9174 while Present (Curr) loop 9175 9176 -- Retrieve the subtype mark or name within the current current 9177 -- use clause. 9178 9179 if Nkind (Curr) = N_Use_Type_Clause then 9180 N := Subtype_Mark (Curr); 9181 else 9182 N := Name (Curr); 9183 end if; 9184 9185 -- If warnings for unreferenced entities are enabled and the 9186 -- current use clause has not been marked effective. 9187 9188 if Check_Unreferenced 9189 and then Comes_From_Source (Curr) 9190 and then not Is_Effective_Use_Clause (Curr) 9191 and then not In_Instance 9192 and then not In_Inlined_Body 9193 then 9194 -- We are dealing with a potentially unused use_package_clause 9195 9196 if Nkind (Curr) = N_Use_Package_Clause then 9197 9198 -- Renamings and formal subprograms may cause the associated 9199 -- node to be marked as effective instead of the original. 9200 9201 if not (Present (Associated_Node (N)) 9202 and then Present 9203 (Current_Use_Clause 9204 (Associated_Node (N))) 9205 and then Is_Effective_Use_Clause 9206 (Current_Use_Clause 9207 (Associated_Node (N)))) 9208 then 9209 Error_Msg_Node_1 := Entity (N); 9210 Error_Msg_NE 9211 ("use clause for package & has no effect?u?", 9212 Curr, Entity (N)); 9213 end if; 9214 9215 -- We are dealing with an unused use_type_clause 9216 9217 else 9218 Error_Msg_Node_1 := Etype (N); 9219 Error_Msg_NE 9220 ("use clause for } has no effect?u?", Curr, Etype (N)); 9221 end if; 9222 end if; 9223 9224 -- Verify that we haven't already processed a redundant 9225 -- use_type_clause within the same scope before we move the 9226 -- current use clause up to a previous one for type T. 9227 9228 if Present (Prev_Use_Clause (Curr)) then 9229 Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr)); 9230 end if; 9231 9232 Curr := Next_Use_Clause (Curr); 9233 end loop; 9234 end Update_Chain_In_Scope; 9235 9236 -- Start of processing for Update_Use_Clause_Chain 9237 9238 begin 9239 Update_Chain_In_Scope (Scope_Stack.Last); 9240 9241 -- Deal with use clauses within the context area if the current 9242 -- scope is a compilation unit. 9243 9244 if Is_Compilation_Unit (Current_Scope) 9245 and then Sloc (Scope_Stack.Table 9246 (Scope_Stack.Last - 1).Entity) = Standard_Location 9247 then 9248 Update_Chain_In_Scope (Scope_Stack.Last - 1); 9249 end if; 9250 end Update_Use_Clause_Chain; 9251 9252 --------------------- 9253 -- Use_One_Package -- 9254 --------------------- 9255 9256 procedure Use_One_Package 9257 (N : Node_Id; 9258 Pack_Name : Entity_Id := Empty; 9259 Force : Boolean := False) 9260 is 9261 procedure Note_Redundant_Use (Clause : Node_Id); 9262 -- Mark the name in a use clause as redundant if the corresponding 9263 -- entity is already use-visible. Emit a warning if the use clause comes 9264 -- from source and the proper warnings are enabled. 9265 9266 ------------------------ 9267 -- Note_Redundant_Use -- 9268 ------------------------ 9269 9270 procedure Note_Redundant_Use (Clause : Node_Id) is 9271 Decl : constant Node_Id := Parent (Clause); 9272 Pack_Name : constant Entity_Id := Entity (Clause); 9273 9274 Cur_Use : Node_Id := Current_Use_Clause (Pack_Name); 9275 Prev_Use : Node_Id := Empty; 9276 Redundant : Node_Id := Empty; 9277 -- The Use_Clause which is actually redundant. In the simplest case 9278 -- it is Pack itself, but when we compile a body we install its 9279 -- context before that of its spec, in which case it is the 9280 -- use_clause in the spec that will appear to be redundant, and we 9281 -- want the warning to be placed on the body. Similar complications 9282 -- appear when the redundancy is between a child unit and one of its 9283 -- ancestors. 9284 9285 begin 9286 -- Could be renamed... 9287 9288 if No (Cur_Use) then 9289 Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name)); 9290 end if; 9291 9292 Set_Redundant_Use (Clause, True); 9293 9294 if not Comes_From_Source (Clause) 9295 or else In_Instance 9296 or else not Warn_On_Redundant_Constructs 9297 then 9298 return; 9299 end if; 9300 9301 if not Is_Compilation_Unit (Current_Scope) then 9302 9303 -- If the use_clause is in an inner scope, it is made redundant by 9304 -- some clause in the current context, with one exception: If we 9305 -- are compiling a nested package body, and the use_clause comes 9306 -- from then corresponding spec, the clause is not necessarily 9307 -- fully redundant, so we should not warn. If a warning was 9308 -- warranted, it would have been given when the spec was 9309 -- processed. 9310 9311 if Nkind (Parent (Decl)) = N_Package_Specification then 9312 declare 9313 Package_Spec_Entity : constant Entity_Id := 9314 Defining_Unit_Name (Parent (Decl)); 9315 begin 9316 if In_Package_Body (Package_Spec_Entity) then 9317 return; 9318 end if; 9319 end; 9320 end if; 9321 9322 Redundant := Clause; 9323 Prev_Use := Cur_Use; 9324 9325 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then 9326 declare 9327 Cur_Unit : constant Unit_Number_Type := 9328 Get_Source_Unit (Cur_Use); 9329 New_Unit : constant Unit_Number_Type := 9330 Get_Source_Unit (Clause); 9331 9332 Scop : Entity_Id; 9333 9334 begin 9335 if Cur_Unit = New_Unit then 9336 9337 -- Redundant clause in same body 9338 9339 Redundant := Clause; 9340 Prev_Use := Cur_Use; 9341 9342 elsif Cur_Unit = Current_Sem_Unit then 9343 9344 -- If the new clause is not in the current unit it has been 9345 -- analyzed first, and it makes the other one redundant. 9346 -- However, if the new clause appears in a subunit, Cur_Unit 9347 -- is still the parent, and in that case the redundant one 9348 -- is the one appearing in the subunit. 9349 9350 if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then 9351 Redundant := Clause; 9352 Prev_Use := Cur_Use; 9353 9354 -- Most common case: redundant clause in body, original 9355 -- clause in spec. Current scope is spec entity. 9356 9357 elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then 9358 Redundant := Cur_Use; 9359 Prev_Use := Clause; 9360 9361 else 9362 -- The new clause may appear in an unrelated unit, when 9363 -- the parents of a generic are being installed prior to 9364 -- instantiation. In this case there must be no warning. 9365 -- We detect this case by checking whether the current 9366 -- top of the stack is related to the current 9367 -- compilation. 9368 9369 Scop := Current_Scope; 9370 while Present (Scop) 9371 and then Scop /= Standard_Standard 9372 loop 9373 if Is_Compilation_Unit (Scop) 9374 and then not Is_Child_Unit (Scop) 9375 then 9376 return; 9377 9378 elsif Scop = Cunit_Entity (Current_Sem_Unit) then 9379 exit; 9380 end if; 9381 9382 Scop := Scope (Scop); 9383 end loop; 9384 9385 Redundant := Cur_Use; 9386 Prev_Use := Clause; 9387 end if; 9388 9389 elsif New_Unit = Current_Sem_Unit then 9390 Redundant := Clause; 9391 Prev_Use := Cur_Use; 9392 9393 else 9394 -- Neither is the current unit, so they appear in parent or 9395 -- sibling units. Warning will be emitted elsewhere. 9396 9397 return; 9398 end if; 9399 end; 9400 9401 elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 9402 and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) 9403 then 9404 -- Use_clause is in child unit of current unit, and the child unit 9405 -- appears in the context of the body of the parent, so it has 9406 -- been installed first, even though it is the redundant one. 9407 -- Depending on their placement in the context, the visible or the 9408 -- private parts of the two units, either might appear as 9409 -- redundant, but the message has to be on the current unit. 9410 9411 if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then 9412 Redundant := Cur_Use; 9413 Prev_Use := Clause; 9414 else 9415 Redundant := Clause; 9416 Prev_Use := Cur_Use; 9417 end if; 9418 9419 -- If the new use clause appears in the private part of a parent 9420 -- unit it may appear to be redundant w.r.t. a use clause in a 9421 -- child unit, but the previous use clause was needed in the 9422 -- visible part of the child, and no warning should be emitted. 9423 9424 if Nkind (Parent (Decl)) = N_Package_Specification 9425 and then List_Containing (Decl) = 9426 Private_Declarations (Parent (Decl)) 9427 then 9428 declare 9429 Par : constant Entity_Id := Defining_Entity (Parent (Decl)); 9430 Spec : constant Node_Id := 9431 Specification (Unit (Cunit (Current_Sem_Unit))); 9432 9433 begin 9434 if Is_Compilation_Unit (Par) 9435 and then Par /= Cunit_Entity (Current_Sem_Unit) 9436 and then Parent (Cur_Use) = Spec 9437 and then List_Containing (Cur_Use) = 9438 Visible_Declarations (Spec) 9439 then 9440 return; 9441 end if; 9442 end; 9443 end if; 9444 9445 -- Finally, if the current use clause is in the context then the 9446 -- clause is redundant when it is nested within the unit. 9447 9448 elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit 9449 and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit 9450 and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) 9451 then 9452 Redundant := Clause; 9453 Prev_Use := Cur_Use; 9454 9455 end if; 9456 9457 if Present (Redundant) and then Parent (Redundant) /= Prev_Use then 9458 9459 -- Make sure we are looking at most-descendant use_package_clause 9460 -- by traversing the chain with Find_Most_Prev and then verifying 9461 -- there is no scope manipulation via Most_Descendant_Use_Clause. 9462 9463 if Nkind (Prev_Use) = N_Use_Package_Clause 9464 and then 9465 (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit 9466 or else Most_Descendant_Use_Clause 9467 (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use) 9468 then 9469 Prev_Use := Find_Most_Prev (Prev_Use); 9470 end if; 9471 9472 Error_Msg_Sloc := Sloc (Prev_Use); 9473 Error_Msg_NE -- CODEFIX 9474 ("& is already use-visible through previous use_clause #??", 9475 Redundant, Pack_Name); 9476 end if; 9477 end Note_Redundant_Use; 9478 9479 -- Local variables 9480 9481 Current_Instance : Entity_Id := Empty; 9482 Id : Entity_Id; 9483 P : Entity_Id; 9484 Prev : Entity_Id; 9485 Private_With_OK : Boolean := False; 9486 Real_P : Entity_Id; 9487 9488 -- Start of processing for Use_One_Package 9489 9490 begin 9491 -- Use_One_Package may have been called recursively to handle an 9492 -- implicit use for a auxiliary system package, so set P accordingly 9493 -- and skip redundancy checks. 9494 9495 if No (Pack_Name) and then Present_System_Aux (N) then 9496 P := System_Aux_Id; 9497 9498 -- Check for redundant use_package_clauses 9499 9500 else 9501 -- Ignore cases where we are dealing with a non user defined package 9502 -- like Standard_Standard or something other than a valid package. 9503 9504 if not Is_Entity_Name (Pack_Name) 9505 or else No (Entity (Pack_Name)) 9506 or else Ekind (Entity (Pack_Name)) /= E_Package 9507 then 9508 return; 9509 end if; 9510 9511 -- When a renaming exists we must check it for redundancy. The 9512 -- original package would have already been seen at this point. 9513 9514 if Present (Renamed_Object (Entity (Pack_Name))) then 9515 P := Renamed_Object (Entity (Pack_Name)); 9516 else 9517 P := Entity (Pack_Name); 9518 end if; 9519 9520 -- Check for redundant clauses then set the current use clause for 9521 -- P if were are not "forcing" an installation from a scope 9522 -- reinstallation that is done throughout analysis for various 9523 -- reasons. 9524 9525 if In_Use (P) then 9526 Note_Redundant_Use (Pack_Name); 9527 9528 if not Force then 9529 Set_Current_Use_Clause (P, N); 9530 end if; 9531 9532 return; 9533 9534 -- Warn about detected redundant clauses 9535 9536 elsif not Force 9537 and then In_Open_Scopes (P) 9538 and then not Is_Hidden_Open_Scope (P) 9539 then 9540 if Warn_On_Redundant_Constructs and then P = Current_Scope then 9541 Error_Msg_NE -- CODEFIX 9542 ("& is already use-visible within itself?r?", 9543 Pack_Name, P); 9544 end if; 9545 9546 return; 9547 end if; 9548 9549 -- Set P back to the non-renamed package so that visiblilty of the 9550 -- entities within the package can be properly set below. 9551 9552 P := Entity (Pack_Name); 9553 end if; 9554 9555 Set_In_Use (P); 9556 Set_Current_Use_Clause (P, N); 9557 9558 -- Ada 2005 (AI-50217): Check restriction 9559 9560 if From_Limited_With (P) then 9561 Error_Msg_N ("limited withed package cannot appear in use clause", N); 9562 end if; 9563 9564 -- Find enclosing instance, if any 9565 9566 if In_Instance then 9567 Current_Instance := Current_Scope; 9568 while not Is_Generic_Instance (Current_Instance) loop 9569 Current_Instance := Scope (Current_Instance); 9570 end loop; 9571 9572 if No (Hidden_By_Use_Clause (N)) then 9573 Set_Hidden_By_Use_Clause (N, New_Elmt_List); 9574 end if; 9575 end if; 9576 9577 -- If unit is a package renaming, indicate that the renamed package is 9578 -- also in use (the flags on both entities must remain consistent, and a 9579 -- subsequent use of either of them should be recognized as redundant). 9580 9581 if Present (Renamed_Object (P)) then 9582 Set_In_Use (Renamed_Object (P)); 9583 Set_Current_Use_Clause (Renamed_Object (P), N); 9584 Real_P := Renamed_Object (P); 9585 else 9586 Real_P := P; 9587 end if; 9588 9589 -- Ada 2005 (AI-262): Check the use_clause of a private withed package 9590 -- found in the private part of a package specification 9591 9592 if In_Private_Part (Current_Scope) 9593 and then Has_Private_With (P) 9594 and then Is_Child_Unit (Current_Scope) 9595 and then Is_Child_Unit (P) 9596 and then Is_Ancestor_Package (Scope (Current_Scope), P) 9597 then 9598 Private_With_OK := True; 9599 end if; 9600 9601 -- Loop through entities in one package making them potentially 9602 -- use-visible. 9603 9604 Id := First_Entity (P); 9605 while Present (Id) 9606 and then (Id /= First_Private_Entity (P) 9607 or else Private_With_OK) -- Ada 2005 (AI-262) 9608 loop 9609 Prev := Current_Entity (Id); 9610 while Present (Prev) loop 9611 if Is_Immediately_Visible (Prev) 9612 and then (not Is_Overloadable (Prev) 9613 or else not Is_Overloadable (Id) 9614 or else (Type_Conformant (Id, Prev))) 9615 then 9616 if No (Current_Instance) then 9617 9618 -- Potentially use-visible entity remains hidden 9619 9620 goto Next_Usable_Entity; 9621 9622 -- A use clause within an instance hides outer global entities, 9623 -- which are not used to resolve local entities in the 9624 -- instance. Note that the predefined entities in Standard 9625 -- could not have been hidden in the generic by a use clause, 9626 -- and therefore remain visible. Other compilation units whose 9627 -- entities appear in Standard must be hidden in an instance. 9628 9629 -- To determine whether an entity is external to the instance 9630 -- we compare the scope depth of its scope with that of the 9631 -- current instance. However, a generic actual of a subprogram 9632 -- instance is declared in the wrapper package but will not be 9633 -- hidden by a use-visible entity. similarly, an entity that is 9634 -- declared in an enclosing instance will not be hidden by an 9635 -- an entity declared in a generic actual, which can only have 9636 -- been use-visible in the generic and will not have hidden the 9637 -- entity in the generic parent. 9638 9639 -- If Id is called Standard, the predefined package with the 9640 -- same name is in the homonym chain. It has to be ignored 9641 -- because it has no defined scope (being the only entity in 9642 -- the system with this mandated behavior). 9643 9644 elsif not Is_Hidden (Id) 9645 and then Present (Scope (Prev)) 9646 and then not Is_Wrapper_Package (Scope (Prev)) 9647 and then Scope_Depth (Scope (Prev)) < 9648 Scope_Depth (Current_Instance) 9649 and then (Scope (Prev) /= Standard_Standard 9650 or else Sloc (Prev) > Standard_Location) 9651 then 9652 if In_Open_Scopes (Scope (Prev)) 9653 and then Is_Generic_Instance (Scope (Prev)) 9654 and then Present (Associated_Formal_Package (P)) 9655 then 9656 null; 9657 9658 else 9659 Set_Is_Potentially_Use_Visible (Id); 9660 Set_Is_Immediately_Visible (Prev, False); 9661 Append_Elmt (Prev, Hidden_By_Use_Clause (N)); 9662 end if; 9663 end if; 9664 9665 -- A user-defined operator is not use-visible if the predefined 9666 -- operator for the type is immediately visible, which is the case 9667 -- if the type of the operand is in an open scope. This does not 9668 -- apply to user-defined operators that have operands of different 9669 -- types, because the predefined mixed mode operations (multiply 9670 -- and divide) apply to universal types and do not hide anything. 9671 9672 elsif Ekind (Prev) = E_Operator 9673 and then Operator_Matches_Spec (Prev, Id) 9674 and then In_Open_Scopes 9675 (Scope (Base_Type (Etype (First_Formal (Id))))) 9676 and then (No (Next_Formal (First_Formal (Id))) 9677 or else Etype (First_Formal (Id)) = 9678 Etype (Next_Formal (First_Formal (Id))) 9679 or else Chars (Prev) = Name_Op_Expon) 9680 then 9681 goto Next_Usable_Entity; 9682 9683 -- In an instance, two homonyms may become use_visible through the 9684 -- actuals of distinct formal packages. In the generic, only the 9685 -- current one would have been visible, so make the other one 9686 -- not use_visible. 9687 9688 -- In certain pathological cases it is possible that unrelated 9689 -- homonyms from distinct formal packages may exist in an 9690 -- uninstalled scope. We must test for that here. 9691 9692 elsif Present (Current_Instance) 9693 and then Is_Potentially_Use_Visible (Prev) 9694 and then not Is_Overloadable (Prev) 9695 and then Scope (Id) /= Scope (Prev) 9696 and then Used_As_Generic_Actual (Scope (Prev)) 9697 and then Used_As_Generic_Actual (Scope (Id)) 9698 and then Is_List_Member (Scope (Prev)) 9699 and then not In_Same_List (Current_Use_Clause (Scope (Prev)), 9700 Current_Use_Clause (Scope (Id))) 9701 then 9702 Set_Is_Potentially_Use_Visible (Prev, False); 9703 Append_Elmt (Prev, Hidden_By_Use_Clause (N)); 9704 end if; 9705 9706 Prev := Homonym (Prev); 9707 end loop; 9708 9709 -- On exit, we know entity is not hidden, unless it is private 9710 9711 if not Is_Hidden (Id) 9712 and then ((not Is_Child_Unit (Id)) or else Is_Visible_Lib_Unit (Id)) 9713 then 9714 Set_Is_Potentially_Use_Visible (Id); 9715 9716 if Is_Private_Type (Id) and then Present (Full_View (Id)) then 9717 Set_Is_Potentially_Use_Visible (Full_View (Id)); 9718 end if; 9719 end if; 9720 9721 <<Next_Usable_Entity>> 9722 Next_Entity (Id); 9723 end loop; 9724 9725 -- Child units are also made use-visible by a use clause, but they may 9726 -- appear after all visible declarations in the parent entity list. 9727 9728 while Present (Id) loop 9729 if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then 9730 Set_Is_Potentially_Use_Visible (Id); 9731 end if; 9732 9733 Next_Entity (Id); 9734 end loop; 9735 9736 if Chars (Real_P) = Name_System 9737 and then Scope (Real_P) = Standard_Standard 9738 and then Present_System_Aux (N) 9739 then 9740 Use_One_Package (N); 9741 end if; 9742 end Use_One_Package; 9743 9744 ------------------ 9745 -- Use_One_Type -- 9746 ------------------ 9747 9748 procedure Use_One_Type 9749 (Id : Node_Id; 9750 Installed : Boolean := False; 9751 Force : Boolean := False) 9752 is 9753 function Spec_Reloaded_For_Body return Boolean; 9754 -- Determine whether the compilation unit is a package body and the use 9755 -- type clause is in the spec of the same package. Even though the spec 9756 -- was analyzed first, its context is reloaded when analysing the body. 9757 9758 procedure Use_Class_Wide_Operations (Typ : Entity_Id); 9759 -- AI05-150: if the use_type_clause carries the "all" qualifier, 9760 -- class-wide operations of ancestor types are use-visible if the 9761 -- ancestor type is visible. 9762 9763 ---------------------------- 9764 -- Spec_Reloaded_For_Body -- 9765 ---------------------------- 9766 9767 function Spec_Reloaded_For_Body return Boolean is 9768 begin 9769 if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then 9770 declare 9771 Spec : constant Node_Id := 9772 Parent (List_Containing (Parent (Id))); 9773 9774 begin 9775 -- Check whether type is declared in a package specification, 9776 -- and current unit is the corresponding package body. The 9777 -- use clauses themselves may be within a nested package. 9778 9779 return 9780 Nkind (Spec) = N_Package_Specification 9781 and then In_Same_Source_Unit 9782 (Corresponding_Body (Parent (Spec)), 9783 Cunit_Entity (Current_Sem_Unit)); 9784 end; 9785 end if; 9786 9787 return False; 9788 end Spec_Reloaded_For_Body; 9789 9790 ------------------------------- 9791 -- Use_Class_Wide_Operations -- 9792 ------------------------------- 9793 9794 procedure Use_Class_Wide_Operations (Typ : Entity_Id) is 9795 function Is_Class_Wide_Operation_Of 9796 (Op : Entity_Id; 9797 T : Entity_Id) return Boolean; 9798 -- Determine whether a subprogram has a class-wide parameter or 9799 -- result that is T'Class. 9800 9801 --------------------------------- 9802 -- Is_Class_Wide_Operation_Of -- 9803 --------------------------------- 9804 9805 function Is_Class_Wide_Operation_Of 9806 (Op : Entity_Id; 9807 T : Entity_Id) return Boolean 9808 is 9809 Formal : Entity_Id; 9810 9811 begin 9812 Formal := First_Formal (Op); 9813 while Present (Formal) loop 9814 if Etype (Formal) = Class_Wide_Type (T) then 9815 return True; 9816 end if; 9817 9818 Next_Formal (Formal); 9819 end loop; 9820 9821 if Etype (Op) = Class_Wide_Type (T) then 9822 return True; 9823 end if; 9824 9825 return False; 9826 end Is_Class_Wide_Operation_Of; 9827 9828 -- Local variables 9829 9830 Ent : Entity_Id; 9831 Scop : Entity_Id; 9832 9833 -- Start of processing for Use_Class_Wide_Operations 9834 9835 begin 9836 Scop := Scope (Typ); 9837 if not Is_Hidden (Scop) then 9838 Ent := First_Entity (Scop); 9839 while Present (Ent) loop 9840 if Is_Overloadable (Ent) 9841 and then Is_Class_Wide_Operation_Of (Ent, Typ) 9842 and then not Is_Potentially_Use_Visible (Ent) 9843 then 9844 Set_Is_Potentially_Use_Visible (Ent); 9845 Append_Elmt (Ent, Used_Operations (Parent (Id))); 9846 end if; 9847 9848 Next_Entity (Ent); 9849 end loop; 9850 end if; 9851 9852 if Is_Derived_Type (Typ) then 9853 Use_Class_Wide_Operations (Etype (Base_Type (Typ))); 9854 end if; 9855 end Use_Class_Wide_Operations; 9856 9857 -- Local variables 9858 9859 Elmt : Elmt_Id; 9860 Is_Known_Used : Boolean; 9861 Op_List : Elist_Id; 9862 T : Entity_Id; 9863 9864 -- Start of processing for Use_One_Type 9865 9866 begin 9867 if Entity (Id) = Any_Type then 9868 return; 9869 end if; 9870 9871 -- It is the type determined by the subtype mark (8.4(8)) whose 9872 -- operations become potentially use-visible. 9873 9874 T := Base_Type (Entity (Id)); 9875 9876 -- Either the type itself is used, the package where it is declared is 9877 -- in use or the entity is declared in the current package, thus 9878 -- use-visible. 9879 9880 Is_Known_Used := 9881 (In_Use (T) 9882 and then ((Present (Current_Use_Clause (T)) 9883 and then All_Present (Current_Use_Clause (T))) 9884 or else not All_Present (Parent (Id)))) 9885 or else In_Use (Scope (T)) 9886 or else Scope (T) = Current_Scope; 9887 9888 Set_Redundant_Use (Id, 9889 Is_Known_Used or else Is_Potentially_Use_Visible (T)); 9890 9891 if Ekind (T) = E_Incomplete_Type then 9892 Error_Msg_N ("premature usage of incomplete type", Id); 9893 9894 elsif In_Open_Scopes (Scope (T)) then 9895 null; 9896 9897 -- A limited view cannot appear in a use_type_clause. However, an access 9898 -- type whose designated type is limited has the flag but is not itself 9899 -- a limited view unless we only have a limited view of its enclosing 9900 -- package. 9901 9902 elsif From_Limited_With (T) and then From_Limited_With (Scope (T)) then 9903 Error_Msg_N 9904 ("incomplete type from limited view cannot appear in use clause", 9905 Id); 9906 9907 -- If the use clause is redundant, Used_Operations will usually be 9908 -- empty, but we need to set it to empty here in one case: If we are 9909 -- instantiating a generic library unit, then we install the ancestors 9910 -- of that unit in the scope stack, which involves reprocessing use 9911 -- clauses in those ancestors. Such a use clause will typically have a 9912 -- nonempty Used_Operations unless it was redundant in the generic unit, 9913 -- even if it is redundant at the place of the instantiation. 9914 9915 elsif Redundant_Use (Id) then 9916 9917 -- We must avoid incorrectly setting the Current_Use_Clause when we 9918 -- are working with a redundant clause that has already been linked 9919 -- in the Prev_Use_Clause chain, otherwise the chain will break. 9920 9921 if Present (Current_Use_Clause (T)) 9922 and then Present (Prev_Use_Clause (Current_Use_Clause (T))) 9923 and then Parent (Id) = Prev_Use_Clause (Current_Use_Clause (T)) 9924 then 9925 null; 9926 else 9927 Set_Current_Use_Clause (T, Parent (Id)); 9928 end if; 9929 9930 Set_Used_Operations (Parent (Id), New_Elmt_List); 9931 9932 -- If the subtype mark designates a subtype in a different package, 9933 -- we have to check that the parent type is visible, otherwise the 9934 -- use_type_clause is a no-op. Not clear how to do that??? 9935 9936 else 9937 Set_Current_Use_Clause (T, Parent (Id)); 9938 Set_In_Use (T); 9939 9940 -- If T is tagged, primitive operators on class-wide operands are 9941 -- also available. 9942 9943 if Is_Tagged_Type (T) then 9944 Set_In_Use (Class_Wide_Type (T)); 9945 end if; 9946 9947 -- Iterate over primitive operations of the type. If an operation is 9948 -- already use_visible, it is the result of a previous use_clause, 9949 -- and already appears on the corresponding entity chain. If the 9950 -- clause is being reinstalled, operations are already use-visible. 9951 9952 if Installed then 9953 null; 9954 9955 else 9956 Op_List := Collect_Primitive_Operations (T); 9957 Elmt := First_Elmt (Op_List); 9958 while Present (Elmt) loop 9959 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol 9960 or else Chars (Node (Elmt)) in Any_Operator_Name) 9961 and then not Is_Hidden (Node (Elmt)) 9962 and then not Is_Potentially_Use_Visible (Node (Elmt)) 9963 then 9964 Set_Is_Potentially_Use_Visible (Node (Elmt)); 9965 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); 9966 9967 elsif Ada_Version >= Ada_2012 9968 and then All_Present (Parent (Id)) 9969 and then not Is_Hidden (Node (Elmt)) 9970 and then not Is_Potentially_Use_Visible (Node (Elmt)) 9971 then 9972 Set_Is_Potentially_Use_Visible (Node (Elmt)); 9973 Append_Elmt (Node (Elmt), Used_Operations (Parent (Id))); 9974 end if; 9975 9976 Next_Elmt (Elmt); 9977 end loop; 9978 end if; 9979 9980 if Ada_Version >= Ada_2012 9981 and then All_Present (Parent (Id)) 9982 and then Is_Tagged_Type (T) 9983 then 9984 Use_Class_Wide_Operations (T); 9985 end if; 9986 end if; 9987 9988 -- If warning on redundant constructs, check for unnecessary WITH 9989 9990 if not Force 9991 and then Warn_On_Redundant_Constructs 9992 and then Is_Known_Used 9993 9994 -- with P; with P; use P; 9995 -- package P is package X is package body X is 9996 -- type T ... use P.T; 9997 9998 -- The compilation unit is the body of X. GNAT first compiles the 9999 -- spec of X, then proceeds to the body. At that point P is marked 10000 -- as use visible. The analysis then reinstalls the spec along with 10001 -- its context. The use clause P.T is now recognized as redundant, 10002 -- but in the wrong context. Do not emit a warning in such cases. 10003 -- Do not emit a warning either if we are in an instance, there is 10004 -- no redundancy between an outer use_clause and one that appears 10005 -- within the generic. 10006 10007 and then not Spec_Reloaded_For_Body 10008 and then not In_Instance 10009 and then not In_Inlined_Body 10010 then 10011 -- The type already has a use clause 10012 10013 if In_Use (T) then 10014 10015 -- Case where we know the current use clause for the type 10016 10017 if Present (Current_Use_Clause (T)) then 10018 Use_Clause_Known : declare 10019 Clause1 : constant Node_Id := 10020 Find_Most_Prev (Current_Use_Clause (T)); 10021 Clause2 : constant Node_Id := Parent (Id); 10022 Ent1 : Entity_Id; 10023 Ent2 : Entity_Id; 10024 Err_No : Node_Id; 10025 Unit1 : Node_Id; 10026 Unit2 : Node_Id; 10027 10028 -- Start of processing for Use_Clause_Known 10029 10030 begin 10031 -- If both current use_type_clause and the use_type_clause 10032 -- for the type are at the compilation unit level, one of 10033 -- the units must be an ancestor of the other, and the 10034 -- warning belongs on the descendant. 10035 10036 if Nkind (Parent (Clause1)) = N_Compilation_Unit 10037 and then 10038 Nkind (Parent (Clause2)) = N_Compilation_Unit 10039 then 10040 -- If the unit is a subprogram body that acts as spec, 10041 -- the context clause is shared with the constructed 10042 -- subprogram spec. Clearly there is no redundancy. 10043 10044 if Clause1 = Clause2 then 10045 return; 10046 end if; 10047 10048 Unit1 := Unit (Parent (Clause1)); 10049 Unit2 := Unit (Parent (Clause2)); 10050 10051 -- If both clauses are on same unit, or one is the body 10052 -- of the other, or one of them is in a subunit, report 10053 -- redundancy on the later one. 10054 10055 if Unit1 = Unit2 or else Nkind (Unit1) = N_Subunit then 10056 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10057 Error_Msg_NE -- CODEFIX 10058 ("& is already use-visible through previous " 10059 & "use_type_clause #??", Clause1, T); 10060 return; 10061 10062 elsif Nkind_In (Unit2, N_Package_Body, N_Subprogram_Body) 10063 and then Nkind (Unit1) /= Nkind (Unit2) 10064 and then Nkind (Unit1) /= N_Subunit 10065 then 10066 Error_Msg_Sloc := Sloc (Clause1); 10067 Error_Msg_NE -- CODEFIX 10068 ("& is already use-visible through previous " 10069 & "use_type_clause #??", Current_Use_Clause (T), T); 10070 return; 10071 end if; 10072 10073 -- There is a redundant use_type_clause in a child unit. 10074 -- Determine which of the units is more deeply nested. 10075 -- If a unit is a package instance, retrieve the entity 10076 -- and its scope from the instance spec. 10077 10078 Ent1 := Entity_Of_Unit (Unit1); 10079 Ent2 := Entity_Of_Unit (Unit2); 10080 10081 if Scope (Ent2) = Standard_Standard then 10082 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10083 Err_No := Clause1; 10084 10085 elsif Scope (Ent1) = Standard_Standard then 10086 Error_Msg_Sloc := Sloc (Id); 10087 Err_No := Clause2; 10088 10089 -- If both units are child units, we determine which one 10090 -- is the descendant by the scope distance to the 10091 -- ultimate parent unit. 10092 10093 else 10094 declare 10095 S1 : Entity_Id; 10096 S2 : Entity_Id; 10097 10098 begin 10099 S1 := Scope (Ent1); 10100 S2 := Scope (Ent2); 10101 while Present (S1) 10102 and then Present (S2) 10103 and then S1 /= Standard_Standard 10104 and then S2 /= Standard_Standard 10105 loop 10106 S1 := Scope (S1); 10107 S2 := Scope (S2); 10108 end loop; 10109 10110 if S1 = Standard_Standard then 10111 Error_Msg_Sloc := Sloc (Id); 10112 Err_No := Clause2; 10113 else 10114 Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); 10115 Err_No := Clause1; 10116 end if; 10117 end; 10118 end if; 10119 10120 if Parent (Id) /= Err_No then 10121 if Most_Descendant_Use_Clause 10122 (Err_No, Parent (Id)) = Parent (Id) 10123 then 10124 Error_Msg_Sloc := Sloc (Err_No); 10125 Err_No := Parent (Id); 10126 end if; 10127 10128 Error_Msg_NE -- CODEFIX 10129 ("& is already use-visible through previous " 10130 & "use_type_clause #??", Err_No, Id); 10131 end if; 10132 10133 -- Case where current use_type_clause and use_type_clause 10134 -- for the type are not both at the compilation unit level. 10135 -- In this case we don't have location information. 10136 10137 else 10138 Error_Msg_NE -- CODEFIX 10139 ("& is already use-visible through previous " 10140 & "use_type_clause??", Id, T); 10141 end if; 10142 end Use_Clause_Known; 10143 10144 -- Here if Current_Use_Clause is not set for T, another case where 10145 -- we do not have the location information available. 10146 10147 else 10148 Error_Msg_NE -- CODEFIX 10149 ("& is already use-visible through previous " 10150 & "use_type_clause??", Id, T); 10151 end if; 10152 10153 -- The package where T is declared is already used 10154 10155 elsif In_Use (Scope (T)) then 10156 Error_Msg_Sloc := 10157 Sloc (Find_Most_Prev (Current_Use_Clause (Scope (T)))); 10158 Error_Msg_NE -- CODEFIX 10159 ("& is already use-visible through package use clause #??", 10160 Id, T); 10161 10162 -- The current scope is the package where T is declared 10163 10164 else 10165 Error_Msg_Node_2 := Scope (T); 10166 Error_Msg_NE -- CODEFIX 10167 ("& is already use-visible inside package &??", Id, T); 10168 end if; 10169 end if; 10170 end Use_One_Type; 10171 10172 ---------------- 10173 -- Write_Info -- 10174 ---------------- 10175 10176 procedure Write_Info is 10177 Id : Entity_Id := First_Entity (Current_Scope); 10178 10179 begin 10180 -- No point in dumping standard entities 10181 10182 if Current_Scope = Standard_Standard then 10183 return; 10184 end if; 10185 10186 Write_Str ("========================================================"); 10187 Write_Eol; 10188 Write_Str (" Defined Entities in "); 10189 Write_Name (Chars (Current_Scope)); 10190 Write_Eol; 10191 Write_Str ("========================================================"); 10192 Write_Eol; 10193 10194 if No (Id) then 10195 Write_Str ("-- none --"); 10196 Write_Eol; 10197 10198 else 10199 while Present (Id) loop 10200 Write_Entity_Info (Id, " "); 10201 Next_Entity (Id); 10202 end loop; 10203 end if; 10204 10205 if Scope (Current_Scope) = Standard_Standard then 10206 10207 -- Print information on the current unit itself 10208 10209 Write_Entity_Info (Current_Scope, " "); 10210 end if; 10211 10212 Write_Eol; 10213 end Write_Info; 10214 10215 -------- 10216 -- ws -- 10217 -------- 10218 10219 procedure ws is 10220 S : Entity_Id; 10221 begin 10222 for J in reverse 1 .. Scope_Stack.Last loop 10223 S := Scope_Stack.Table (J).Entity; 10224 Write_Int (Int (S)); 10225 Write_Str (" === "); 10226 Write_Name (Chars (S)); 10227 Write_Eol; 10228 end loop; 10229 end ws; 10230 10231 -------- 10232 -- we -- 10233 -------- 10234 10235 procedure we (S : Entity_Id) is 10236 E : Entity_Id; 10237 begin 10238 E := First_Entity (S); 10239 while Present (E) loop 10240 Write_Int (Int (E)); 10241 Write_Str (" === "); 10242 Write_Name (Chars (E)); 10243 Write_Eol; 10244 Next_Entity (E); 10245 end loop; 10246 end we; 10247end Sem_Ch8; 10248