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