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