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