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