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