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-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Util; use Exp_Util; 33with Fname; use Fname; 34with Freeze; use Freeze; 35with Lib; use Lib; 36with Lib.Load; use Lib.Load; 37with Lib.Xref; use Lib.Xref; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Output; use Output; 43with Restrict; use Restrict; 44with Rtsfind; use Rtsfind; 45with Sem; use Sem; 46with Sem_Cat; use Sem_Cat; 47with Sem_Ch3; use Sem_Ch3; 48with Sem_Ch4; use Sem_Ch4; 49with Sem_Ch6; use Sem_Ch6; 50with Sem_Ch12; use Sem_Ch12; 51with Sem_Res; use Sem_Res; 52with Sem_Util; use Sem_Util; 53with Sem_Type; use Sem_Type; 54with Stand; use Stand; 55with Sinfo; use Sinfo; 56with Sinfo.CN; use Sinfo.CN; 57with Snames; use Snames; 58with Style; use Style; 59with Table; 60with Tbuild; use Tbuild; 61with Uintp; use Uintp; 62 63with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 64 65package body Sem_Ch8 is 66 67 ------------------------------------ 68 -- Visibility and Name Resolution -- 69 ------------------------------------ 70 71 -- This package handles name resolution and the collection of 72 -- interpretations for overloaded names, prior to overload resolution. 73 74 -- Name resolution is the process that establishes a mapping between source 75 -- identifiers and the entities they denote at each point in the program. 76 -- Each entity is represented by a defining occurrence. Each identifier 77 -- that denotes an entity points to the corresponding defining occurrence. 78 -- This is the entity of the applied occurrence. Each occurrence holds 79 -- an index into the names table, where source identifiers are stored. 80 81 -- Each entry in the names table for an identifier or designator uses the 82 -- Info pointer to hold a link to the currently visible entity that has 83 -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id 84 -- in package Sem_Util). The visibility is initialized at the beginning of 85 -- semantic processing to make entities in package Standard immediately 86 -- visible. The visibility table is used in a more subtle way when 87 -- compiling subunits (see below). 88 89 -- Entities that have the same name (i.e. homonyms) are chained. In the 90 -- case of overloaded entities, this chain holds all the possible meanings 91 -- of a given identifier. The process of overload resolution uses type 92 -- information to select from this chain the unique meaning of a given 93 -- identifier. 94 95 -- Entities are also chained in their scope, through the Next_Entity link. 96 -- As a consequence, the name space is organized as a sparse matrix, where 97 -- each row corresponds to a scope, and each column to a source identifier. 98 -- Open scopes, that is to say scopes currently being compiled, have their 99 -- corresponding rows of entities in order, innermost scope first. 100 101 -- The scopes of packages that are mentioned in context clauses appear in 102 -- no particular order, interspersed among open scopes. This is because 103 -- in the course of analyzing the context of a compilation, a package 104 -- declaration is first an open scope, and subsequently an element of the 105 -- context. If subunits or child units are present, a parent unit may 106 -- appear under various guises at various times in the compilation. 107 108 -- When the compilation of the innermost scope is complete, the entities 109 -- defined therein are no longer visible. If the scope is not a package 110 -- declaration, these entities are never visible subsequently, and can be 111 -- removed from visibility chains. If the scope is a package declaration, 112 -- its visible declarations may still be accessible. Therefore the entities 113 -- defined in such a scope are left on the visibility chains, and only 114 -- their visibility (immediately visibility or potential use-visibility) 115 -- is affected. 116 117 -- The ordering of homonyms on their chain does not necessarily follow 118 -- the order of their corresponding scopes on the scope stack. For 119 -- example, if package P and the enclosing scope both contain entities 120 -- named E, then when compiling the package body the chain for E will 121 -- hold the global entity first, and the local one (corresponding to 122 -- the current inner scope) next. As a result, name resolution routines 123 -- do not assume any relative ordering of the homonym chains, either 124 -- for scope nesting or to order of appearance of context clauses. 125 126 -- When compiling a child unit, entities in the parent scope are always 127 -- immediately visible. When compiling the body of a child unit, private 128 -- entities in the parent must also be made immediately visible. There 129 -- are separate routines to make the visible and private declarations 130 -- visible at various times (see package Sem_Ch7). 131 132 -- +--------+ +-----+ 133 -- | In use |-------->| EU1 |--------------------------> 134 -- +--------+ +-----+ 135 -- | | 136 -- +--------+ +-----+ +-----+ 137 -- | Stand. |---------------->| ES1 |--------------->| ES2 |---> 138 -- +--------+ +-----+ +-----+ 139 -- | | 140 -- +---------+ | +-----+ 141 -- | with'ed |------------------------------>| EW2 |---> 142 -- +---------+ | +-----+ 143 -- | | 144 -- +--------+ +-----+ +-----+ 145 -- | Scope2 |---------------->| E12 |--------------->| E22 |---> 146 -- +--------+ +-----+ +-----+ 147 -- | | 148 -- +--------+ +-----+ +-----+ 149 -- | Scope1 |---------------->| E11 |--------------->| E12 |---> 150 -- +--------+ +-----+ +-----+ 151 -- ^ | | 152 -- | | | 153 -- | +---------+ | | 154 -- | | with'ed |-----------------------------------------> 155 -- | +---------+ | | 156 -- | | | 157 -- Scope stack | | 158 -- (innermost first) | | 159 -- +----------------------------+ 160 -- Names table => | Id1 | | | | Id2 | 161 -- +----------------------------+ 162 163 -- Name resolution must deal with several syntactic forms: simple names, 164 -- qualified names, indexed names, and various forms of calls. 165 166 -- Each identifier points to an entry in the names table. The resolution 167 -- of a simple name consists in traversing the homonym chain, starting 168 -- from the names table. If an entry is immediately visible, it is the one 169 -- designated by the identifier. If only potentially use-visible entities 170 -- are on the chain, we must verify that they do not hide each other. If 171 -- the entity we find is overloadable, we collect all other overloadable 172 -- entities on the chain as long as they are not hidden. 173 -- 174 -- To resolve expanded names, we must find the entity at the intersection 175 -- of the entity chain for the scope (the prefix) and the homonym chain 176 -- for the selector. In general, homonym chains will be much shorter than 177 -- entity chains, so it is preferable to start from the names table as 178 -- well. If the entity found is overloadable, we must collect all other 179 -- interpretations that are defined in the scope denoted by the prefix. 180 181 -- For records, protected types, and tasks, their local entities are 182 -- removed from visibility chains on exit from the corresponding scope. 183 -- From the outside, these entities are always accessed by selected 184 -- notation, and the entity chain for the record type, protected type, 185 -- etc. is traversed sequentially in order to find the designated entity. 186 187 -- The discriminants of a type and the operations of a protected type or 188 -- task are unchained on exit from the first view of the type, (such as 189 -- a private or incomplete type declaration, or a protected type speci- 190 -- fication) and re-chained when compiling the second view. 191 192 -- In the case of operators, we do not make operators on derived types 193 -- explicit. As a result, the notation P."+" may denote either a user- 194 -- defined function with name "+", or else an implicit declaration of the 195 -- operator "+" in package P. The resolution of expanded names always 196 -- tries to resolve an operator name as such an implicitly defined entity, 197 -- in addition to looking for explicit declarations. 198 199 -- All forms of names that denote entities (simple names, expanded names, 200 -- character literals in some cases) have a Entity attribute, which 201 -- identifies the entity denoted by the name. 202 203 --------------------- 204 -- The Scope Stack -- 205 --------------------- 206 207 -- The Scope stack keeps track of the scopes currently been compiled. 208 -- Every entity that contains declarations (including records) is placed 209 -- on the scope stack while it is being processed, and removed at the end. 210 -- Whenever a non-package scope is exited, the entities defined therein 211 -- are removed from the visibility table, so that entities in outer scopes 212 -- become visible (see previous description). On entry to Sem, the scope 213 -- stack only contains the package Standard. As usual, subunits complicate 214 -- this picture ever so slightly. 215 216 -- The Rtsfind mechanism can force a call to Semantics while another 217 -- compilation is in progress. The unit retrieved by Rtsfind must be 218 -- compiled in its own context, and has no access to the visibility of 219 -- the unit currently being compiled. The procedures Save_Scope_Stack and 220 -- Restore_Scope_Stack make entities in current open scopes invisible 221 -- before compiling the retrieved unit, and restore the compilation 222 -- environment afterwards. 223 224 ------------------------ 225 -- Compiling subunits -- 226 ------------------------ 227 228 -- Subunits must be compiled in the environment of the corresponding 229 -- stub, that is to say with the same visibility into the parent (and its 230 -- context) that is available at the point of the stub declaration, but 231 -- with the additional visibility provided by the context clause of the 232 -- subunit itself. As a result, compilation of a subunit forces compilation 233 -- of the parent (see description in lib-). At the point of the stub 234 -- declaration, Analyze is called recursively to compile the proper body 235 -- of the subunit, but without reinitializing the names table, nor the 236 -- scope stack (i.e. standard is not pushed on the stack). In this fashion 237 -- the context of the subunit is added to the context of the parent, and 238 -- the subunit is compiled in the correct environment. Note that in the 239 -- course of processing the context of a subunit, Standard will appear 240 -- twice on the scope stack: once for the parent of the subunit, and 241 -- once for the unit in the context clause being compiled. However, the 242 -- two sets of entities are not linked by homonym chains, so that the 243 -- compilation of any context unit happens in a fresh visibility 244 -- environment. 245 246 ------------------------------- 247 -- Processing of USE Clauses -- 248 ------------------------------- 249 250 -- Every defining occurrence has a flag indicating if it is potentially use 251 -- visible. Resolution of simple names examines this flag. The processing 252 -- of use clauses consists in setting this flag on all visible entities 253 -- defined in the corresponding package. On exit from the scope of the use 254 -- clause, the corresponding flag must be reset. However, a package may 255 -- appear in several nested use clauses (pathological but legal, alas!) 256 -- which forces us to use a slightly more involved scheme: 257 258 -- a) The defining occurrence for a package holds a flag -In_Use- to 259 -- indicate that it is currently in the scope of a use clause. If a 260 -- redundant use clause is encountered, then the corresponding occurrence 261 -- of the package name is flagged -Redundant_Use-. 262 263 -- b) On exit from a scope, the use clauses in its declarative part are 264 -- scanned. The visibility flag is reset in all entities declared in 265 -- package named in a use clause, as long as the package is not flagged 266 -- as being in a redundant use clause (in which case the outer use 267 -- clause is still in effect, and the direct visibility of its entities 268 -- must be retained). 269 270 -- Note that entities are not removed from their homonym chains on exit 271 -- from the package specification. A subsequent use clause does not need 272 -- to rechain the visible entities, but only to establish their direct 273 -- visibility. 274 275 ----------------------------------- 276 -- Handling private declarations -- 277 ----------------------------------- 278 279 -- The principle that each entity has a single defining occurrence clashes 280 -- with the presence of two separate definitions for private types: the 281 -- first is the private type declaration, and second is the full type 282 -- declaration. It is important that all references to the type point to 283 -- the same defining occurrence, namely the first one. To enforce the two 284 -- separate views of the entity, the corresponding information is swapped 285 -- between the two declarations. Outside of the package, the defining 286 -- occurrence only contains the private declaration information, while in 287 -- the private part and the body of the package the defining occurrence 288 -- contains the full declaration. To simplify the swap, the defining 289 -- occurrence that currently holds the private declaration points to the 290 -- full declaration. During semantic processing the defining occurrence 291 -- also points to a list of private dependents, that is to say access 292 -- types or composite types whose designated types or component types are 293 -- subtypes or derived types of the private type in question. After the 294 -- full declaration has been seen, the private dependents are updated to 295 -- indicate that they have full definitions. 296 297 ------------------------------------ 298 -- Handling of Undefined Messages -- 299 ------------------------------------ 300 301 -- In normal mode, only the first use of an undefined identifier generates 302 -- a message. The table Urefs is used to record error messages that have 303 -- been issued so that second and subsequent ones do not generate further 304 -- messages. However, the second reference causes text to be added to the 305 -- original undefined message noting "(more references follow)". The 306 -- full error list option (-gnatf) forces messages to be generated for 307 -- every reference and disconnects the use of this table. 308 309 type Uref_Entry is record 310 Node : Node_Id; 311 -- Node for identifier for which original message was posted. The 312 -- Chars field of this identifier is used to detect later references 313 -- to the same identifier. 314 315 Err : Error_Msg_Id; 316 -- Records error message Id of original undefined message. Reset to 317 -- No_Error_Msg after the second occurrence, where it is used to add 318 -- text to the original message as described above. 319 320 Nvis : Boolean; 321 -- Set if the message is not visible rather than undefined 322 323 Loc : Source_Ptr; 324 -- Records location of error message. Used to make sure that we do 325 -- not consider a, b : undefined as two separate instances, which 326 -- would otherwise happen, since the parser converts this sequence 327 -- to a : undefined; b : undefined. 328 329 end record; 330 331 package Urefs is new Table.Table ( 332 Table_Component_Type => Uref_Entry, 333 Table_Index_Type => Nat, 334 Table_Low_Bound => 1, 335 Table_Initial => 10, 336 Table_Increment => 100, 337 Table_Name => "Urefs"); 338 339 Candidate_Renaming : Entity_Id; 340 -- Holds a candidate interpretation that appears in a subprogram renaming 341 -- declaration and does not match the given specification, but matches at 342 -- least on the first formal. Allows better error message when given 343 -- specification omits defaulted parameters, a common error. 344 345 ----------------------- 346 -- Local Subprograms -- 347 ----------------------- 348 349 procedure Analyze_Generic_Renaming 350 (N : Node_Id; 351 K : Entity_Kind); 352 -- Common processing for all three kinds of generic renaming declarations. 353 -- Enter new name and indicate that it renames the generic unit. 354 355 procedure Analyze_Renamed_Character 356 (N : Node_Id; 357 New_S : Entity_Id; 358 Is_Body : Boolean); 359 -- Renamed entity is given by a character literal, which must belong 360 -- to the return type of the new entity. Is_Body indicates whether the 361 -- declaration is a renaming_as_body. If the original declaration has 362 -- already been frozen (because of an intervening body, e.g.) the body of 363 -- the function must be built now. The same applies to the following 364 -- various renaming procedures. 365 366 procedure Analyze_Renamed_Dereference 367 (N : Node_Id; 368 New_S : Entity_Id; 369 Is_Body : Boolean); 370 -- Renamed entity is given by an explicit dereference. Prefix must be a 371 -- conformant access_to_subprogram type. 372 373 procedure Analyze_Renamed_Entry 374 (N : Node_Id; 375 New_S : Entity_Id; 376 Is_Body : Boolean); 377 -- If the renamed entity in a subprogram renaming is an entry or protected 378 -- subprogram, build a body for the new entity whose only statement is a 379 -- call to the renamed entity. 380 381 procedure Analyze_Renamed_Family_Member 382 (N : Node_Id; 383 New_S : Entity_Id; 384 Is_Body : Boolean); 385 -- Used when the renamed entity is an indexed component. The prefix must 386 -- denote an entry family. 387 388 function Applicable_Use (Pack_Name : Node_Id) return Boolean; 389 -- Common code to Use_One_Package and Set_Use, to determine whether 390 -- use clause must be processed. Pack_Name is an entity name that 391 -- references the package in question. 392 393 procedure Attribute_Renaming (N : Node_Id); 394 -- Analyze renaming of attribute as function. The renaming declaration N 395 -- is rewritten as a function body that returns the attribute reference 396 -- applied to the formals of the function. 397 398 procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); 399 -- A renaming_as_body may occur after the entity of the original decla- 400 -- ration has been frozen. In that case, the body of the new entity must 401 -- be built now, because the usual mechanism of building the renamed 402 -- body at the point of freezing will not work. Subp is the subprogram 403 -- for which N provides the Renaming_As_Body. 404 405 procedure Check_In_Previous_With_Clause 406 (N : Node_Id; 407 Nam : Node_Id); 408 -- N is a use_package clause and Nam the package name, or N is a use_type 409 -- clause and Nam is the prefix of the type name. In either case, verify 410 -- that the package is visible at that point in the context: either it 411 -- appears in a previous with_clause, or because it is a fully qualified 412 -- name and the root ancestor appears in a previous with_clause. 413 414 procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id); 415 -- Verify that the entity in a renaming declaration that is a library unit 416 -- is itself a library unit and not a nested unit or subunit. Also check 417 -- that if the renaming is a child unit of a generic parent, then the 418 -- renamed unit must also be a child unit of that parent. Finally, verify 419 -- that a renamed generic unit is not an implicit child declared within 420 -- an instance of the parent. 421 422 procedure Chain_Use_Clause (N : Node_Id); 423 -- Chain use clause onto list of uses clauses headed by First_Use_Clause 424 -- in the top scope table entry. 425 426 function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; 427 -- Find a type derived from Character or Wide_Character in the prefix of N. 428 -- Used to resolved qualified names whose selector is a character literal. 429 430 procedure Find_Expanded_Name (N : Node_Id); 431 -- Selected component is known to be expanded name. Verify legality 432 -- of selector given the scope denoted by prefix. 433 434 function Find_Renamed_Entity 435 (N : Node_Id; 436 Nam : Node_Id; 437 New_S : Entity_Id; 438 Is_Actual : Boolean := False) return Entity_Id; 439 -- Find the renamed entity that corresponds to the given parameter profile 440 -- in a subprogram renaming declaration. The renamed entity may be an 441 -- operator, a subprogram, an entry, or a protected operation. Is_Actual 442 -- indicates that the renaming is the one generated for an actual subpro- 443 -- gram in an instance, for which special visibility checks apply. 444 445 function Has_Implicit_Operator (N : Node_Id) return Boolean; 446 -- N is an expanded name whose selector is an operator name (eg P."+"). 447 -- A declarative part contains an implicit declaration of an operator 448 -- if it has a declaration of a type to which one of the predefined 449 -- operators apply. The existence of this routine is an artifact of 450 -- our implementation: a more straightforward but more space-consuming 451 -- choice would be to make all inherited operators explicit in the 452 -- symbol table. 453 454 procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id); 455 -- A subprogram defined by a renaming declaration inherits the parameter 456 -- profile of the renamed entity. The subtypes given in the subprogram 457 -- specification are discarded and replaced with those of the renamed 458 -- subprogram, which are then used to recheck the default values. 459 460 function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; 461 -- Prefix is appropriate for record if it is of a record type, or 462 -- an access to such. 463 464 function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; 465 -- True if it is of a task type, a protected type, or else an access 466 -- to one of these types. 467 468 procedure Premature_Usage (N : Node_Id); 469 -- Diagnose usage of an entity before it is visible. 470 471 procedure Use_One_Package (P : Entity_Id; N : Node_Id); 472 -- Make visible entities declared in package P potentially use-visible 473 -- in the current context. Also used in the analysis of subunits, when 474 -- re-installing use clauses of parent units. N is the use_clause that 475 -- names P (and possibly other packages). 476 477 procedure Use_One_Type (Id : Node_Id); 478 -- Id is the subtype mark from a use type clause. This procedure makes 479 -- the primitive operators of the type potentially use-visible. 480 481 procedure Write_Info; 482 -- Write debugging information on entities declared in current scope 483 484 procedure Write_Scopes; 485 pragma Warnings (Off, Write_Scopes); 486 -- Debugging information: dump all entities on scope stack 487 488 -------------------------------- 489 -- Analyze_Exception_Renaming -- 490 -------------------------------- 491 492 -- The language only allows a single identifier, but the tree holds 493 -- an identifier list. The parser has already issued an error message 494 -- if there is more than one element in the list. 495 496 procedure Analyze_Exception_Renaming (N : Node_Id) is 497 Id : constant Node_Id := Defining_Identifier (N); 498 Nam : constant Node_Id := Name (N); 499 500 begin 501 Enter_Name (Id); 502 Analyze (Nam); 503 504 Set_Ekind (Id, E_Exception); 505 Set_Exception_Code (Id, Uint_0); 506 Set_Etype (Id, Standard_Exception_Type); 507 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 508 509 if not Is_Entity_Name (Nam) or else 510 Ekind (Entity (Nam)) /= E_Exception 511 then 512 Error_Msg_N ("invalid exception name in renaming", Nam); 513 else 514 if Present (Renamed_Object (Entity (Nam))) then 515 Set_Renamed_Object (Id, Renamed_Object (Entity (Nam))); 516 else 517 Set_Renamed_Object (Id, Entity (Nam)); 518 end if; 519 end if; 520 end Analyze_Exception_Renaming; 521 522 --------------------------- 523 -- Analyze_Expanded_Name -- 524 --------------------------- 525 526 procedure Analyze_Expanded_Name (N : Node_Id) is 527 begin 528 -- If the entity pointer is already set, this is an internal node, or 529 -- a node that is analyzed more than once, after a tree modification. 530 -- In such a case there is no resolution to perform, just set the type. 531 -- For completeness, analyze prefix as well. 532 533 if Present (Entity (N)) then 534 if Is_Type (Entity (N)) then 535 Set_Etype (N, Entity (N)); 536 else 537 Set_Etype (N, Etype (Entity (N))); 538 end if; 539 540 Analyze (Prefix (N)); 541 return; 542 else 543 Find_Expanded_Name (N); 544 end if; 545 end Analyze_Expanded_Name; 546 547 ---------------------------------------- 548 -- Analyze_Generic_Function_Renaming -- 549 ---------------------------------------- 550 551 procedure Analyze_Generic_Function_Renaming (N : Node_Id) is 552 begin 553 Analyze_Generic_Renaming (N, E_Generic_Function); 554 end Analyze_Generic_Function_Renaming; 555 556 --------------------------------------- 557 -- Analyze_Generic_Package_Renaming -- 558 --------------------------------------- 559 560 procedure Analyze_Generic_Package_Renaming (N : Node_Id) is 561 begin 562 -- Apply the Text_IO Kludge here, since we may be renaming 563 -- one of the subpackages of Text_IO, then join common routine. 564 565 Text_IO_Kludge (Name (N)); 566 567 Analyze_Generic_Renaming (N, E_Generic_Package); 568 end Analyze_Generic_Package_Renaming; 569 570 ----------------------------------------- 571 -- Analyze_Generic_Procedure_Renaming -- 572 ----------------------------------------- 573 574 procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is 575 begin 576 Analyze_Generic_Renaming (N, E_Generic_Procedure); 577 end Analyze_Generic_Procedure_Renaming; 578 579 ------------------------------ 580 -- Analyze_Generic_Renaming -- 581 ------------------------------ 582 583 procedure Analyze_Generic_Renaming 584 (N : Node_Id; 585 K : Entity_Kind) 586 is 587 New_P : constant Entity_Id := Defining_Entity (N); 588 Old_P : Entity_Id; 589 Inst : Boolean := False; -- prevent junk warning 590 591 begin 592 if Name (N) = Error then 593 return; 594 end if; 595 596 Generate_Definition (New_P); 597 598 if Current_Scope /= Standard_Standard then 599 Set_Is_Pure (New_P, Is_Pure (Current_Scope)); 600 end if; 601 602 if Nkind (Name (N)) = N_Selected_Component then 603 Check_Generic_Child_Unit (Name (N), Inst); 604 else 605 Analyze (Name (N)); 606 end if; 607 608 if not Is_Entity_Name (Name (N)) then 609 Error_Msg_N ("expect entity name in renaming declaration", Name (N)); 610 Old_P := Any_Id; 611 else 612 Old_P := Entity (Name (N)); 613 end if; 614 615 Enter_Name (New_P); 616 Set_Ekind (New_P, K); 617 618 if Etype (Old_P) = Any_Type then 619 null; 620 621 elsif Ekind (Old_P) /= K then 622 Error_Msg_N ("invalid generic unit name", Name (N)); 623 624 else 625 if Present (Renamed_Object (Old_P)) then 626 Set_Renamed_Object (New_P, Renamed_Object (Old_P)); 627 else 628 Set_Renamed_Object (New_P, Old_P); 629 end if; 630 631 Set_Etype (New_P, Etype (Old_P)); 632 Set_Has_Completion (New_P); 633 634 if In_Open_Scopes (Old_P) then 635 Error_Msg_N ("within its scope, generic denotes its instance", N); 636 end if; 637 638 Check_Library_Unit_Renaming (N, Old_P); 639 end if; 640 641 end Analyze_Generic_Renaming; 642 643 ----------------------------- 644 -- Analyze_Object_Renaming -- 645 ----------------------------- 646 647 procedure Analyze_Object_Renaming (N : Node_Id) is 648 Id : constant Entity_Id := Defining_Identifier (N); 649 Dec : Node_Id; 650 Nam : constant Node_Id := Name (N); 651 S : constant Entity_Id := Subtype_Mark (N); 652 T : Entity_Id; 653 T2 : Entity_Id; 654 655 begin 656 if Nam = Error then 657 return; 658 end if; 659 660 Set_Is_Pure (Id, Is_Pure (Current_Scope)); 661 Enter_Name (Id); 662 663 -- The renaming of a component that depends on a discriminant 664 -- requires an actual subtype, because in subsequent use of the object 665 -- Gigi will be unable to locate the actual bounds. This explicit step 666 -- is required when the renaming is generated in removing side effects 667 -- of an already-analyzed expression. 668 669 if Nkind (Nam) = N_Selected_Component 670 and then Analyzed (Nam) 671 then 672 T := Etype (Nam); 673 Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam); 674 675 if Present (Dec) then 676 Insert_Action (N, Dec); 677 T := Defining_Identifier (Dec); 678 Set_Etype (Nam, T); 679 end if; 680 681 else 682 Find_Type (S); 683 T := Entity (S); 684 Analyze_And_Resolve (Nam, T); 685 end if; 686 687 -- An object renaming requires an exact match of the type; 688 -- class-wide matching is not allowed. 689 690 if Is_Class_Wide_Type (T) 691 and then Base_Type (Etype (Nam)) /= Base_Type (T) 692 then 693 Wrong_Type (Nam, T); 694 end if; 695 696 T2 := Etype (Nam); 697 Set_Ekind (Id, E_Variable); 698 Init_Size_Align (Id); 699 700 if T = Any_Type or else Etype (Nam) = Any_Type then 701 return; 702 703 -- Verify that the renamed entity is an object or a function call. 704 -- It may have been rewritten in several ways. 705 706 elsif Is_Object_Reference (Nam) then 707 if Comes_From_Source (N) 708 and then Is_Dependent_Component_Of_Mutable_Object (Nam) 709 then 710 Error_Msg_N 711 ("illegal renaming of discriminant-dependent component", Nam); 712 else 713 null; 714 end if; 715 716 -- A static function call may have been folded into a literal 717 718 elsif Nkind (Original_Node (Nam)) = N_Function_Call 719 720 -- When expansion is disabled, attribute reference is not 721 -- rewritten as function call. Otherwise it may be rewritten 722 -- as a conversion, so check original node. 723 724 or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference 725 and then Is_Function_Attribute_Name 726 (Attribute_Name (Original_Node (Nam)))) 727 728 -- Weird but legal, equivalent to renaming a function call. 729 730 or else (Is_Entity_Name (Nam) 731 and then Ekind (Entity (Nam)) = E_Enumeration_Literal) 732 733 or else (Nkind (Nam) = N_Type_Conversion 734 and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) 735 then 736 null; 737 738 else 739 if Nkind (Nam) = N_Type_Conversion then 740 Error_Msg_N 741 ("renaming of conversion only allowed for tagged types", Nam); 742 743 else 744 Error_Msg_N ("expect object name in renaming", Nam); 745 end if; 746 747 end if; 748 749 Set_Etype (Id, T2); 750 751 if not Is_Variable (Nam) then 752 Set_Ekind (Id, E_Constant); 753 Set_Never_Set_In_Source (Id, True); 754 Set_Is_True_Constant (Id, True); 755 end if; 756 757 Set_Renamed_Object (Id, Nam); 758 end Analyze_Object_Renaming; 759 760 ------------------------------ 761 -- Analyze_Package_Renaming -- 762 ------------------------------ 763 764 procedure Analyze_Package_Renaming (N : Node_Id) is 765 New_P : constant Entity_Id := Defining_Entity (N); 766 Old_P : Entity_Id; 767 Spec : Node_Id; 768 769 begin 770 if Name (N) = Error then 771 return; 772 end if; 773 774 -- Apply Text_IO kludge here, since we may be renaming one of 775 -- the children of Text_IO 776 777 Text_IO_Kludge (Name (N)); 778 779 if Current_Scope /= Standard_Standard then 780 Set_Is_Pure (New_P, Is_Pure (Current_Scope)); 781 end if; 782 783 Enter_Name (New_P); 784 Analyze (Name (N)); 785 if Is_Entity_Name (Name (N)) then 786 Old_P := Entity (Name (N)); 787 else 788 Old_P := Any_Id; 789 end if; 790 791 if Etype (Old_P) = Any_Type then 792 Error_Msg_N 793 ("expect package name in renaming", Name (N)); 794 795 -- Ada0Y (AI-50217): Limited withed packages can not be renamed 796 797 elsif Ekind (Old_P) = E_Package 798 and then From_With_Type (Old_P) 799 then 800 Error_Msg_N 801 ("limited withed package cannot be renamed", Name (N)); 802 803 elsif Ekind (Old_P) /= E_Package 804 and then not (Ekind (Old_P) = E_Generic_Package 805 and then In_Open_Scopes (Old_P)) 806 then 807 if Ekind (Old_P) = E_Generic_Package then 808 Error_Msg_N 809 ("generic package cannot be renamed as a package", Name (N)); 810 else 811 Error_Msg_Sloc := Sloc (Old_P); 812 Error_Msg_NE 813 ("expect package name in renaming, found& declared#", 814 Name (N), Old_P); 815 end if; 816 817 -- Set basic attributes to minimize cascaded errors. 818 819 Set_Ekind (New_P, E_Package); 820 Set_Etype (New_P, Standard_Void_Type); 821 822 else 823 -- Entities in the old package are accessible through the 824 -- renaming entity. The simplest implementation is to have 825 -- both packages share the entity list. 826 827 Set_Ekind (New_P, E_Package); 828 Set_Etype (New_P, Standard_Void_Type); 829 830 if Present (Renamed_Object (Old_P)) then 831 Set_Renamed_Object (New_P, Renamed_Object (Old_P)); 832 else 833 Set_Renamed_Object (New_P, Old_P); 834 end if; 835 836 Set_Has_Completion (New_P); 837 838 Set_First_Entity (New_P, First_Entity (Old_P)); 839 Set_Last_Entity (New_P, Last_Entity (Old_P)); 840 Set_First_Private_Entity (New_P, First_Private_Entity (Old_P)); 841 Check_Library_Unit_Renaming (N, Old_P); 842 Generate_Reference (Old_P, Name (N)); 843 844 -- If this is the renaming declaration of a package instantiation 845 -- within itself, it is the declaration that ends the list of actuals 846 -- for the instantiation. At this point, the subtypes that rename 847 -- the actuals are flagged as generic, to avoid spurious ambiguities 848 -- if the actuals for two distinct formals happen to coincide. If 849 -- the actual is a private type, the subtype has a private completion 850 -- that is flagged in the same fashion. 851 852 -- Resolution is identical to what is was in the original generic. 853 -- On exit from the generic instance, these are turned into regular 854 -- subtypes again, so they are compatible with types in their class. 855 856 if not Is_Generic_Instance (Old_P) then 857 return; 858 else 859 Spec := Specification (Unit_Declaration_Node (Old_P)); 860 end if; 861 862 if Nkind (Spec) = N_Package_Specification 863 and then Present (Generic_Parent (Spec)) 864 and then Old_P = Current_Scope 865 and then Chars (New_P) = Chars (Generic_Parent (Spec)) 866 then 867 declare 868 E : Entity_Id := First_Entity (Old_P); 869 begin 870 while Present (E) 871 and then E /= New_P 872 loop 873 if Is_Type (E) 874 and then Nkind (Parent (E)) = N_Subtype_Declaration 875 then 876 Set_Is_Generic_Actual_Type (E); 877 878 if Is_Private_Type (E) 879 and then Present (Full_View (E)) 880 then 881 Set_Is_Generic_Actual_Type (Full_View (E)); 882 end if; 883 end if; 884 885 Next_Entity (E); 886 end loop; 887 end; 888 end if; 889 end if; 890 891 end Analyze_Package_Renaming; 892 893 ------------------------------- 894 -- Analyze_Renamed_Character -- 895 ------------------------------- 896 897 procedure Analyze_Renamed_Character 898 (N : Node_Id; 899 New_S : Entity_Id; 900 Is_Body : Boolean) 901 is 902 C : constant Node_Id := Name (N); 903 904 begin 905 if Ekind (New_S) = E_Function then 906 Resolve (C, Etype (New_S)); 907 908 if Is_Body then 909 Check_Frozen_Renaming (N, New_S); 910 end if; 911 912 else 913 Error_Msg_N ("character literal can only be renamed as function", N); 914 end if; 915 end Analyze_Renamed_Character; 916 917 --------------------------------- 918 -- Analyze_Renamed_Dereference -- 919 --------------------------------- 920 921 procedure Analyze_Renamed_Dereference 922 (N : Node_Id; 923 New_S : Entity_Id; 924 Is_Body : Boolean) 925 is 926 Nam : constant Node_Id := Name (N); 927 P : constant Node_Id := Prefix (Nam); 928 Typ : Entity_Id; 929 Ind : Interp_Index; 930 It : Interp; 931 932 begin 933 if not Is_Overloaded (P) then 934 if Ekind (Etype (Nam)) /= E_Subprogram_Type 935 or else not Type_Conformant (Etype (Nam), New_S) then 936 Error_Msg_N ("designated type does not match specification", P); 937 else 938 Resolve (P); 939 end if; 940 941 return; 942 943 else 944 Typ := Any_Type; 945 Get_First_Interp (Nam, Ind, It); 946 947 while Present (It.Nam) loop 948 949 if Ekind (It.Nam) = E_Subprogram_Type 950 and then Type_Conformant (It.Nam, New_S) then 951 952 if Typ /= Any_Id then 953 Error_Msg_N ("ambiguous renaming", P); 954 return; 955 else 956 Typ := It.Nam; 957 end if; 958 end if; 959 960 Get_Next_Interp (Ind, It); 961 end loop; 962 963 if Typ = Any_Type then 964 Error_Msg_N ("designated type does not match specification", P); 965 else 966 Resolve (N, Typ); 967 968 if Is_Body then 969 Check_Frozen_Renaming (N, New_S); 970 end if; 971 end if; 972 end if; 973 end Analyze_Renamed_Dereference; 974 975 --------------------------- 976 -- Analyze_Renamed_Entry -- 977 --------------------------- 978 979 procedure Analyze_Renamed_Entry 980 (N : Node_Id; 981 New_S : Entity_Id; 982 Is_Body : Boolean) 983 is 984 Nam : constant Node_Id := Name (N); 985 Sel : constant Node_Id := Selector_Name (Nam); 986 Old_S : Entity_Id; 987 988 begin 989 if Entity (Sel) = Any_Id then 990 991 -- Selector is undefined on prefix. Error emitted already. 992 993 Set_Has_Completion (New_S); 994 return; 995 end if; 996 997 -- Otherwise, find renamed entity, and build body of New_S as a call 998 -- to it. 999 1000 Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); 1001 1002 if Old_S = Any_Id then 1003 Error_Msg_N (" no subprogram or entry matches specification", N); 1004 else 1005 if Is_Body then 1006 Check_Subtype_Conformant (New_S, Old_S, N); 1007 Generate_Reference (New_S, Defining_Entity (N), 'b'); 1008 Style.Check_Identifier (Defining_Entity (N), New_S); 1009 end if; 1010 1011 Inherit_Renamed_Profile (New_S, Old_S); 1012 end if; 1013 1014 Set_Convention (New_S, Convention (Old_S)); 1015 Set_Has_Completion (New_S, Inside_A_Generic); 1016 1017 if Is_Body then 1018 Check_Frozen_Renaming (N, New_S); 1019 end if; 1020 end Analyze_Renamed_Entry; 1021 1022 ----------------------------------- 1023 -- Analyze_Renamed_Family_Member -- 1024 ----------------------------------- 1025 1026 procedure Analyze_Renamed_Family_Member 1027 (N : Node_Id; 1028 New_S : Entity_Id; 1029 Is_Body : Boolean) 1030 is 1031 Nam : constant Node_Id := Name (N); 1032 P : constant Node_Id := Prefix (Nam); 1033 Old_S : Entity_Id; 1034 1035 begin 1036 if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) 1037 or else (Nkind (P) = N_Selected_Component 1038 and then 1039 Ekind (Entity (Selector_Name (P))) = E_Entry_Family) 1040 then 1041 if Is_Entity_Name (P) then 1042 Old_S := Entity (P); 1043 else 1044 Old_S := Entity (Selector_Name (P)); 1045 end if; 1046 1047 if not Entity_Matches_Spec (Old_S, New_S) then 1048 Error_Msg_N ("entry family does not match specification", N); 1049 1050 elsif Is_Body then 1051 Check_Subtype_Conformant (New_S, Old_S, N); 1052 Generate_Reference (New_S, Defining_Entity (N), 'b'); 1053 Style.Check_Identifier (Defining_Entity (N), New_S); 1054 end if; 1055 else 1056 Error_Msg_N ("no entry family matches specification", N); 1057 end if; 1058 1059 Set_Has_Completion (New_S, Inside_A_Generic); 1060 1061 if Is_Body then 1062 Check_Frozen_Renaming (N, New_S); 1063 end if; 1064 end Analyze_Renamed_Family_Member; 1065 1066 --------------------------------- 1067 -- Analyze_Subprogram_Renaming -- 1068 --------------------------------- 1069 1070 procedure Analyze_Subprogram_Renaming (N : Node_Id) is 1071 Spec : constant Node_Id := Specification (N); 1072 Save_83 : constant Boolean := Ada_83; 1073 Nam : constant Node_Id := Name (N); 1074 New_S : Entity_Id; 1075 Old_S : Entity_Id := Empty; 1076 Rename_Spec : Entity_Id; 1077 Is_Actual : Boolean := False; 1078 Inst_Node : Node_Id := Empty; 1079 1080 function Original_Subprogram (Subp : Entity_Id) return Entity_Id; 1081 -- Find renamed entity when the declaration is a renaming_as_body 1082 -- and the renamed entity may itself be a renaming_as_body. Used to 1083 -- enforce rule that a renaming_as_body is illegal if the declaration 1084 -- occurs before the subprogram it completes is frozen, and renaming 1085 -- indirectly renames the subprogram itself.(Defect Report 8652/0027). 1086 1087 ------------------------- 1088 -- Original_Subprogram -- 1089 ------------------------- 1090 1091 function Original_Subprogram (Subp : Entity_Id) return Entity_Id is 1092 Orig_Decl : Node_Id; 1093 Orig_Subp : Entity_Id; 1094 1095 begin 1096 -- First case: renamed entity is itself a renaming 1097 1098 if Present (Alias (Subp)) then 1099 return Alias (Subp); 1100 1101 elsif 1102 Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration 1103 and then Present 1104 (Corresponding_Body (Unit_Declaration_Node (Subp))) 1105 then 1106 -- Check if renamed entity is a renaming_as_body 1107 1108 Orig_Decl := 1109 Unit_Declaration_Node 1110 (Corresponding_Body (Unit_Declaration_Node (Subp))); 1111 1112 if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then 1113 Orig_Subp := Entity (Name (Orig_Decl)); 1114 1115 if Orig_Subp = Rename_Spec then 1116 1117 -- Circularity detected. 1118 1119 return Orig_Subp; 1120 1121 else 1122 return (Original_Subprogram (Orig_Subp)); 1123 end if; 1124 else 1125 return Subp; 1126 end if; 1127 else 1128 return Subp; 1129 end if; 1130 end Original_Subprogram; 1131 1132 -- Start of processing for Analyze_Subprogram_Renaming 1133 1134 begin 1135 -- We must test for the attribute renaming case before the Analyze 1136 -- call because otherwise Sem_Attr will complain that the attribute 1137 -- is missing an argument when it is analyzed. 1138 1139 if Nkind (Nam) = N_Attribute_Reference then 1140 Attribute_Renaming (N); 1141 return; 1142 end if; 1143 1144 -- Check whether this declaration corresponds to the instantiation 1145 -- of a formal subprogram. This is indicated by the presence of a 1146 -- Corresponding_Spec that is the instantiation declaration. 1147 1148 -- If this is an instantiation, the corresponding actual is frozen 1149 -- and error messages can be made more precise. If this is a default 1150 -- subprogram, the entity is already established in the generic, and 1151 -- is not retrieved by visibility. If it is a default with a box, the 1152 -- candidate interpretations, if any, have been collected when building 1153 -- the renaming declaration. If overloaded, the proper interpretation 1154 -- is determined in Find_Renamed_Entity. If the entity is an operator, 1155 -- Find_Renamed_Entity applies additional visibility checks. 1156 1157 if Present (Corresponding_Spec (N)) then 1158 Is_Actual := True; 1159 Inst_Node := Unit_Declaration_Node (Corresponding_Spec (N)); 1160 1161 if Is_Entity_Name (Nam) 1162 and then Present (Entity (Nam)) 1163 and then not Comes_From_Source (Nam) 1164 and then not Is_Overloaded (Nam) 1165 then 1166 Old_S := Entity (Nam); 1167 New_S := Analyze_Subprogram_Specification (Spec); 1168 1169 if Ekind (Entity (Nam)) = E_Operator 1170 and then Box_Present (Inst_Node) 1171 then 1172 Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); 1173 end if; 1174 1175 else 1176 Analyze (Nam); 1177 New_S := Analyze_Subprogram_Specification (Spec); 1178 end if; 1179 1180 Set_Corresponding_Spec (N, Empty); 1181 1182 else 1183 -- Renamed entity must be analyzed first, to avoid being hidden by 1184 -- new name (which might be the same in a generic instance). 1185 1186 Analyze (Nam); 1187 1188 -- The renaming defines a new overloaded entity, which is analyzed 1189 -- like a subprogram declaration. 1190 1191 New_S := Analyze_Subprogram_Specification (Spec); 1192 end if; 1193 1194 if Current_Scope /= Standard_Standard then 1195 Set_Is_Pure (New_S, Is_Pure (Current_Scope)); 1196 end if; 1197 1198 Rename_Spec := Find_Corresponding_Spec (N); 1199 1200 if Present (Rename_Spec) then 1201 1202 -- Renaming_As_Body. Renaming declaration is the completion of 1203 -- the declaration of Rename_Spec. We will build an actual body 1204 -- for it at the freezing point. 1205 1206 Set_Corresponding_Spec (N, Rename_Spec); 1207 Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S); 1208 1209 -- The body is created when the entity is frozen. If the context 1210 -- is generic, freeze_all is not invoked, so we need to indicate 1211 -- that the entity has a completion. 1212 1213 Set_Has_Completion (Rename_Spec, Inside_A_Generic); 1214 1215 if Ada_83 and then Comes_From_Source (N) then 1216 Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N); 1217 end if; 1218 1219 Set_Convention (New_S, Convention (Rename_Spec)); 1220 Check_Fully_Conformant (New_S, Rename_Spec); 1221 Set_Public_Status (New_S); 1222 1223 -- Indicate that the entity in the declaration functions like 1224 -- the corresponding body, and is not a new entity. 1225 1226 Set_Ekind (New_S, E_Subprogram_Body); 1227 New_S := Rename_Spec; 1228 1229 else 1230 Generate_Definition (New_S); 1231 New_Overloaded_Entity (New_S); 1232 if Is_Entity_Name (Nam) 1233 and then Is_Intrinsic_Subprogram (Entity (Nam)) 1234 then 1235 null; 1236 else 1237 Check_Delayed_Subprogram (New_S); 1238 end if; 1239 end if; 1240 1241 -- There is no need for elaboration checks on the new entity, which 1242 -- may be called before the next freezing point where the body will 1243 -- appear. Elaboration checks refer to the real entity, not the one 1244 -- created by the renaming declaration. 1245 1246 Set_Kill_Elaboration_Checks (New_S, True); 1247 1248 if Etype (Nam) = Any_Type then 1249 Set_Has_Completion (New_S); 1250 return; 1251 1252 elsif Nkind (Nam) = N_Selected_Component then 1253 1254 -- Renamed entity is an entry or protected subprogram. For those 1255 -- cases an explicit body is built (at the point of freezing of 1256 -- this entity) that contains a call to the renamed entity. 1257 1258 Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec)); 1259 return; 1260 1261 elsif Nkind (Nam) = N_Explicit_Dereference then 1262 1263 -- Renamed entity is designated by access_to_subprogram expression. 1264 -- Must build body to encapsulate call, as in the entry case. 1265 1266 Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec)); 1267 return; 1268 1269 elsif Nkind (Nam) = N_Indexed_Component then 1270 Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec)); 1271 return; 1272 1273 elsif Nkind (Nam) = N_Character_Literal then 1274 Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); 1275 return; 1276 1277 elsif (not Is_Entity_Name (Nam) 1278 and then Nkind (Nam) /= N_Operator_Symbol) 1279 or else not Is_Overloadable (Entity (Nam)) 1280 then 1281 Error_Msg_N ("expect valid subprogram name in renaming", N); 1282 return; 1283 1284 end if; 1285 1286 -- Most common case: subprogram renames subprogram. No body is 1287 -- generated in this case, so we must indicate that the declaration 1288 -- is complete as is. 1289 1290 if No (Rename_Spec) then 1291 Set_Has_Completion (New_S); 1292 end if; 1293 1294 -- Find the renamed entity that matches the given specification. 1295 -- Disable Ada_83 because there is no requirement of full conformance 1296 -- between renamed entity and new entity, even though the same circuit 1297 -- is used. 1298 1299 Ada_83 := False; 1300 1301 if No (Old_S) then 1302 Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); 1303 end if; 1304 1305 if Old_S /= Any_Id then 1306 1307 if Is_Actual 1308 and then Box_Present (Inst_Node) 1309 then 1310 -- This is an implicit reference to the default actual 1311 1312 Generate_Reference (Old_S, Nam, Typ => 'i', Force => True); 1313 else 1314 Generate_Reference (Old_S, Nam); 1315 end if; 1316 1317 -- For a renaming-as-body, require subtype conformance, 1318 -- but if the declaration being completed has not been 1319 -- frozen, then inherit the convention of the renamed 1320 -- subprogram prior to checking conformance (unless the 1321 -- renaming has an explicit convention established; the 1322 -- rule stated in the RM doesn't seem to address this ???). 1323 1324 if Present (Rename_Spec) then 1325 Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b'); 1326 Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec); 1327 1328 if not Is_Frozen (Rename_Spec) then 1329 if not Has_Convention_Pragma (Rename_Spec) then 1330 Set_Convention (New_S, Convention (Old_S)); 1331 end if; 1332 1333 if Ekind (Old_S) /= E_Operator then 1334 Check_Mode_Conformant (New_S, Old_S, Spec); 1335 end if; 1336 1337 if Original_Subprogram (Old_S) = Rename_Spec then 1338 Error_Msg_N ("unfrozen subprogram cannot rename itself ", N); 1339 end if; 1340 else 1341 Check_Subtype_Conformant (New_S, Old_S, Spec); 1342 end if; 1343 1344 Check_Frozen_Renaming (N, Rename_Spec); 1345 1346 elsif Ekind (Old_S) /= E_Operator then 1347 Check_Mode_Conformant (New_S, Old_S); 1348 1349 if Is_Actual 1350 and then Error_Posted (New_S) 1351 then 1352 Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S); 1353 end if; 1354 end if; 1355 1356 if No (Rename_Spec) then 1357 1358 -- The parameter profile of the new entity is that of the renamed 1359 -- entity: the subtypes given in the specification are irrelevant. 1360 1361 Inherit_Renamed_Profile (New_S, Old_S); 1362 1363 -- A call to the subprogram is transformed into a call to the 1364 -- renamed entity. This is transitive if the renamed entity is 1365 -- itself a renaming. 1366 1367 if Present (Alias (Old_S)) then 1368 Set_Alias (New_S, Alias (Old_S)); 1369 else 1370 Set_Alias (New_S, Old_S); 1371 end if; 1372 1373 -- Note that we do not set Is_Instrinsic_Subprogram if we have 1374 -- a renaming as body, since the entity in this case is not an 1375 -- intrinsic (it calls an intrinsic, but we have a real body 1376 -- for this call, and it is in this body that the required 1377 -- intrinsic processing will take place). 1378 1379 -- Also, if this is a renaming of inequality, the renamed 1380 -- operator is intrinsic, but what matters is the corresponding 1381 -- equality operator, which may be user-defined. 1382 1383 Set_Is_Intrinsic_Subprogram 1384 (New_S, 1385 Is_Intrinsic_Subprogram (Old_S) 1386 and then 1387 (Chars (Old_S) /= Name_Op_Ne 1388 or else Ekind (Old_S) = E_Operator 1389 or else 1390 Is_Intrinsic_Subprogram 1391 (Corresponding_Equality (Old_S)))); 1392 1393 if Ekind (Alias (New_S)) = E_Operator then 1394 Set_Has_Delayed_Freeze (New_S, False); 1395 end if; 1396 1397 end if; 1398 1399 if not Is_Actual 1400 and then (Old_S = New_S 1401 or else (Nkind (Nam) /= N_Expanded_Name 1402 and then Chars (Old_S) = Chars (New_S))) 1403 then 1404 Error_Msg_N ("subprogram cannot rename itself", N); 1405 end if; 1406 1407 Set_Convention (New_S, Convention (Old_S)); 1408 Set_Is_Abstract (New_S, Is_Abstract (Old_S)); 1409 Check_Library_Unit_Renaming (N, Old_S); 1410 1411 -- Pathological case: procedure renames entry in the scope of 1412 -- its task. Entry is given by simple name, but body must be built 1413 -- for procedure. Of course if called it will deadlock. 1414 1415 if Ekind (Old_S) = E_Entry then 1416 Set_Has_Completion (New_S, False); 1417 Set_Alias (New_S, Empty); 1418 end if; 1419 1420 if Is_Actual then 1421 Freeze_Before (N, Old_S); 1422 Set_Has_Delayed_Freeze (New_S, False); 1423 Freeze_Before (N, New_S); 1424 1425 if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) 1426 and then Is_Abstract (Old_S) 1427 then 1428 Error_Msg_N 1429 ("abstract subprogram not allowed as generic actual", Nam); 1430 end if; 1431 end if; 1432 1433 else 1434 -- A common error is to assume that implicit operators for types 1435 -- are defined in Standard, or in the scope of a subtype. In those 1436 -- cases where the renamed entity is given with an expanded name, 1437 -- it is worth mentioning that operators for the type are not 1438 -- declared in the scope given by the prefix. 1439 1440 if Nkind (Nam) = N_Expanded_Name 1441 and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol 1442 and then Scope (Entity (Nam)) = Standard_Standard 1443 then 1444 declare 1445 T : constant Entity_Id := 1446 Base_Type (Etype (First_Formal (New_S))); 1447 1448 begin 1449 Error_Msg_Node_2 := Prefix (Nam); 1450 Error_Msg_NE 1451 ("operator for type& is not declared in&", Prefix (Nam), T); 1452 end; 1453 1454 else 1455 Error_Msg_NE 1456 ("no visible subprogram matches the specification for&", 1457 Spec, New_S); 1458 end if; 1459 1460 if Present (Candidate_Renaming) then 1461 declare 1462 F1 : Entity_Id; 1463 F2 : Entity_Id; 1464 1465 begin 1466 F1 := First_Formal (Candidate_Renaming); 1467 F2 := First_Formal (New_S); 1468 1469 while Present (F1) and then Present (F2) loop 1470 Next_Formal (F1); 1471 Next_Formal (F2); 1472 end loop; 1473 1474 if Present (F1) and then Present (Default_Value (F1)) then 1475 if Present (Next_Formal (F1)) then 1476 Error_Msg_NE 1477 ("\missing specification for &" & 1478 " and other formals with defaults", Spec, F1); 1479 else 1480 Error_Msg_NE 1481 ("\missing specification for &", Spec, F1); 1482 end if; 1483 end if; 1484 end; 1485 end if; 1486 end if; 1487 1488 Ada_83 := Save_83; 1489 end Analyze_Subprogram_Renaming; 1490 1491 ------------------------- 1492 -- Analyze_Use_Package -- 1493 ------------------------- 1494 1495 -- Resolve the package names in the use clause, and make all the visible 1496 -- entities defined in the package potentially use-visible. If the package 1497 -- is already in use from a previous use clause, its visible entities are 1498 -- already use-visible. In that case, mark the occurrence as a redundant 1499 -- use. If the package is an open scope, i.e. if the use clause occurs 1500 -- within the package itself, ignore it. 1501 1502 procedure Analyze_Use_Package (N : Node_Id) is 1503 Pack_Name : Node_Id; 1504 Pack : Entity_Id; 1505 1506 -- Start of processing for Analyze_Use_Package 1507 1508 begin 1509 Set_Hidden_By_Use_Clause (N, No_Elist); 1510 1511 -- Use clause is not allowed in a spec of a predefined package 1512 -- declaration except that packages whose file name starts a-n 1513 -- are OK (these are children of Ada.Numerics, and such packages 1514 -- are never loaded by Rtsfind). 1515 1516 if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) 1517 and then Name_Buffer (1 .. 3) /= "a-n" 1518 and then 1519 Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration 1520 then 1521 Error_Msg_N ("use clause not allowed in predefined spec", N); 1522 end if; 1523 1524 -- Chain clause to list of use clauses in current scope. 1525 1526 if Nkind (Parent (N)) /= N_Compilation_Unit then 1527 Chain_Use_Clause (N); 1528 end if; 1529 1530 -- Loop through package names to identify referenced packages 1531 1532 Pack_Name := First (Names (N)); 1533 1534 while Present (Pack_Name) loop 1535 Analyze (Pack_Name); 1536 1537 if Nkind (Parent (N)) = N_Compilation_Unit 1538 and then Nkind (Pack_Name) = N_Expanded_Name 1539 then 1540 declare 1541 Pref : Node_Id := Prefix (Pack_Name); 1542 1543 begin 1544 while Nkind (Pref) = N_Expanded_Name loop 1545 Pref := Prefix (Pref); 1546 end loop; 1547 1548 if Entity (Pref) = Standard_Standard then 1549 Error_Msg_N 1550 ("predefined package Standard cannot appear" 1551 & " in a context clause", Pref); 1552 end if; 1553 end; 1554 end if; 1555 1556 Next (Pack_Name); 1557 end loop; 1558 1559 -- Loop through package names to mark all entities as potentially 1560 -- use visible. 1561 1562 Pack_Name := First (Names (N)); 1563 1564 while Present (Pack_Name) loop 1565 1566 if Is_Entity_Name (Pack_Name) then 1567 Pack := Entity (Pack_Name); 1568 1569 if Ekind (Pack) /= E_Package 1570 and then Etype (Pack) /= Any_Type 1571 then 1572 if Ekind (Pack) = E_Generic_Package then 1573 Error_Msg_N 1574 ("a generic package is not allowed in a use clause", 1575 Pack_Name); 1576 else 1577 Error_Msg_N ("& is not a usable package", Pack_Name); 1578 end if; 1579 1580 else 1581 if Nkind (Parent (N)) = N_Compilation_Unit then 1582 Check_In_Previous_With_Clause (N, Pack_Name); 1583 end if; 1584 1585 if Applicable_Use (Pack_Name) then 1586 Use_One_Package (Pack, N); 1587 end if; 1588 end if; 1589 end if; 1590 1591 Next (Pack_Name); 1592 end loop; 1593 1594 end Analyze_Use_Package; 1595 1596 ---------------------- 1597 -- Analyze_Use_Type -- 1598 ---------------------- 1599 1600 procedure Analyze_Use_Type (N : Node_Id) is 1601 Id : Entity_Id; 1602 1603 begin 1604 Set_Hidden_By_Use_Clause (N, No_Elist); 1605 1606 -- Chain clause to list of use clauses in current scope. 1607 1608 if Nkind (Parent (N)) /= N_Compilation_Unit then 1609 Chain_Use_Clause (N); 1610 end if; 1611 1612 Id := First (Subtype_Marks (N)); 1613 1614 while Present (Id) loop 1615 Find_Type (Id); 1616 1617 if Entity (Id) /= Any_Type then 1618 Use_One_Type (Id); 1619 1620 if Nkind (Parent (N)) = N_Compilation_Unit then 1621 if Nkind (Id) = N_Identifier then 1622 Error_Msg_N ("Type is not directly visible", Id); 1623 1624 elsif Is_Child_Unit (Scope (Entity (Id))) 1625 and then Scope (Entity (Id)) /= System_Aux_Id 1626 then 1627 Check_In_Previous_With_Clause (N, Prefix (Id)); 1628 end if; 1629 end if; 1630 end if; 1631 1632 Next (Id); 1633 end loop; 1634 end Analyze_Use_Type; 1635 1636 -------------------- 1637 -- Applicable_Use -- 1638 -------------------- 1639 1640 function Applicable_Use (Pack_Name : Node_Id) return Boolean is 1641 Pack : constant Entity_Id := Entity (Pack_Name); 1642 1643 begin 1644 if In_Open_Scopes (Pack) then 1645 return False; 1646 1647 elsif In_Use (Pack) then 1648 Set_Redundant_Use (Pack_Name, True); 1649 return False; 1650 1651 elsif Present (Renamed_Object (Pack)) 1652 and then In_Use (Renamed_Object (Pack)) 1653 then 1654 Set_Redundant_Use (Pack_Name, True); 1655 return False; 1656 1657 else 1658 return True; 1659 end if; 1660 end Applicable_Use; 1661 1662 ------------------------ 1663 -- Attribute_Renaming -- 1664 ------------------------ 1665 1666 procedure Attribute_Renaming (N : Node_Id) is 1667 Loc : constant Source_Ptr := Sloc (N); 1668 Nam : constant Node_Id := Name (N); 1669 Spec : constant Node_Id := Specification (N); 1670 New_S : constant Entity_Id := Defining_Unit_Name (Spec); 1671 Aname : constant Name_Id := Attribute_Name (Nam); 1672 1673 Form_Num : Nat := 0; 1674 Expr_List : List_Id := No_List; 1675 1676 Attr_Node : Node_Id; 1677 Body_Node : Node_Id; 1678 Param_Spec : Node_Id; 1679 1680 begin 1681 Generate_Definition (New_S); 1682 1683 -- This procedure is called in the context of subprogram renaming, 1684 -- and thus the attribute must be one that is a subprogram. All of 1685 -- those have at least one formal parameter, with the singular 1686 -- exception of AST_Entry (which is a real oddity, it is odd that 1687 -- this can be renamed at all!) 1688 1689 if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then 1690 if Aname /= Name_AST_Entry then 1691 Error_Msg_N 1692 ("subprogram renaming an attribute must have formals", N); 1693 return; 1694 end if; 1695 1696 else 1697 Param_Spec := First (Parameter_Specifications (Spec)); 1698 1699 while Present (Param_Spec) loop 1700 Form_Num := Form_Num + 1; 1701 1702 if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then 1703 Find_Type (Parameter_Type (Param_Spec)); 1704 1705 -- The profile of the new entity denotes the base type (s) of 1706 -- the types given in the specification. For access parameters 1707 -- there are no subtypes involved. 1708 1709 Rewrite (Parameter_Type (Param_Spec), 1710 New_Reference_To 1711 (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc)); 1712 end if; 1713 1714 if No (Expr_List) then 1715 Expr_List := New_List; 1716 end if; 1717 1718 Append_To (Expr_List, 1719 Make_Identifier (Loc, 1720 Chars => Chars (Defining_Identifier (Param_Spec)))); 1721 1722 -- The expressions in the attribute reference are not freeze 1723 -- points. Neither is the attribute as a whole, see below. 1724 1725 Set_Must_Not_Freeze (Last (Expr_List)); 1726 Next (Param_Spec); 1727 end loop; 1728 end if; 1729 1730 -- Immediate error if too many formals. Other mismatches in numbers 1731 -- of number of types of parameters are detected when we analyze the 1732 -- body of the subprogram that we construct. 1733 1734 if Form_Num > 2 then 1735 Error_Msg_N ("too many formals for attribute", N); 1736 1737 elsif 1738 Aname = Name_Compose or else 1739 Aname = Name_Exponent or else 1740 Aname = Name_Leading_Part or else 1741 Aname = Name_Pos or else 1742 Aname = Name_Round or else 1743 Aname = Name_Scaling or else 1744 Aname = Name_Val 1745 then 1746 if Nkind (N) = N_Subprogram_Renaming_Declaration 1747 and then Present (Corresponding_Spec (N)) 1748 and then Nkind (Unit_Declaration_Node (Corresponding_Spec (N))) = 1749 N_Formal_Subprogram_Declaration 1750 then 1751 Error_Msg_N 1752 ("generic actual cannot be attribute involving universal type", 1753 Nam); 1754 else 1755 Error_Msg_N 1756 ("attribute involving a universal type cannot be renamed", 1757 Nam); 1758 end if; 1759 end if; 1760 1761 -- AST_Entry is an odd case. It doesn't really make much sense to 1762 -- allow it to be renamed, but that's the DEC rule, so we have to 1763 -- do it right. The point is that the AST_Entry call should be made 1764 -- now, and what the function will return is the returned value. 1765 1766 -- Note that there is no Expr_List in this case anyway 1767 1768 if Aname = Name_AST_Entry then 1769 1770 declare 1771 Ent : Entity_Id; 1772 Decl : Node_Id; 1773 1774 begin 1775 Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); 1776 1777 Decl := 1778 Make_Object_Declaration (Loc, 1779 Defining_Identifier => Ent, 1780 Object_Definition => 1781 New_Occurrence_Of (RTE (RE_AST_Handler), Loc), 1782 Expression => Nam, 1783 Constant_Present => True); 1784 1785 Set_Assignment_OK (Decl, True); 1786 Insert_Action (N, Decl); 1787 Attr_Node := Make_Identifier (Loc, Chars (Ent)); 1788 end; 1789 1790 -- For all other attributes, we rewrite the attribute node to have 1791 -- a list of expressions corresponding to the subprogram formals. 1792 -- A renaming declaration is not a freeze point, and the analysis of 1793 -- the attribute reference should not freeze the type of the prefix. 1794 1795 else 1796 Attr_Node := 1797 Make_Attribute_Reference (Loc, 1798 Prefix => Prefix (Nam), 1799 Attribute_Name => Aname, 1800 Expressions => Expr_List); 1801 1802 Set_Must_Not_Freeze (Attr_Node); 1803 Set_Must_Not_Freeze (Prefix (Nam)); 1804 end if; 1805 1806 -- Case of renaming a function 1807 1808 if Nkind (Spec) = N_Function_Specification then 1809 1810 if Is_Procedure_Attribute_Name (Aname) then 1811 Error_Msg_N ("attribute can only be renamed as procedure", Nam); 1812 return; 1813 end if; 1814 1815 Find_Type (Subtype_Mark (Spec)); 1816 Rewrite (Subtype_Mark (Spec), 1817 New_Reference_To (Base_Type (Entity (Subtype_Mark (Spec))), Loc)); 1818 1819 Body_Node := 1820 Make_Subprogram_Body (Loc, 1821 Specification => Spec, 1822 Declarations => New_List, 1823 Handled_Statement_Sequence => 1824 Make_Handled_Sequence_Of_Statements (Loc, 1825 Statements => New_List ( 1826 Make_Return_Statement (Loc, 1827 Expression => Attr_Node)))); 1828 1829 -- Case of renaming a procedure 1830 1831 else 1832 if not Is_Procedure_Attribute_Name (Aname) then 1833 Error_Msg_N ("attribute can only be renamed as function", Nam); 1834 return; 1835 end if; 1836 1837 Body_Node := 1838 Make_Subprogram_Body (Loc, 1839 Specification => Spec, 1840 Declarations => New_List, 1841 Handled_Statement_Sequence => 1842 Make_Handled_Sequence_Of_Statements (Loc, 1843 Statements => New_List (Attr_Node))); 1844 end if; 1845 1846 Rewrite (N, Body_Node); 1847 Analyze (N); 1848 1849 Set_Etype (New_S, Base_Type (Etype (New_S))); 1850 1851 -- We suppress elaboration warnings for the resulting entity, since 1852 -- clearly they are not needed, and more particularly, in the case 1853 -- of a generic formal subprogram, the resulting entity can appear 1854 -- after the instantiation itself, and thus look like a bogus case 1855 -- of access before elaboration. 1856 1857 Set_Suppress_Elaboration_Warnings (New_S); 1858 1859 end Attribute_Renaming; 1860 1861 ---------------------- 1862 -- Chain_Use_Clause -- 1863 ---------------------- 1864 1865 procedure Chain_Use_Clause (N : Node_Id) is 1866 begin 1867 Set_Next_Use_Clause (N, 1868 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause); 1869 Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N; 1870 end Chain_Use_Clause; 1871 1872 ---------------------------- 1873 -- Check_Frozen_Renaming -- 1874 ---------------------------- 1875 1876 procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id) is 1877 B_Node : Node_Id; 1878 Old_S : Entity_Id; 1879 1880 begin 1881 if Is_Frozen (Subp) 1882 and then not Has_Completion (Subp) 1883 then 1884 B_Node := 1885 Build_Renamed_Body 1886 (Parent (Declaration_Node (Subp)), Defining_Entity (N)); 1887 1888 if Is_Entity_Name (Name (N)) then 1889 Old_S := Entity (Name (N)); 1890 1891 if not Is_Frozen (Old_S) 1892 and then Operating_Mode /= Check_Semantics 1893 then 1894 Append_Freeze_Action (Old_S, B_Node); 1895 else 1896 Insert_After (N, B_Node); 1897 Analyze (B_Node); 1898 end if; 1899 1900 if Is_Intrinsic_Subprogram (Old_S) 1901 and then not In_Instance 1902 then 1903 Error_Msg_N 1904 ("subprogram used in renaming_as_body cannot be intrinsic", 1905 Name (N)); 1906 end if; 1907 1908 else 1909 Insert_After (N, B_Node); 1910 Analyze (B_Node); 1911 end if; 1912 end if; 1913 end Check_Frozen_Renaming; 1914 1915 ----------------------------------- 1916 -- Check_In_Previous_With_Clause -- 1917 ----------------------------------- 1918 1919 procedure Check_In_Previous_With_Clause 1920 (N : Node_Id; 1921 Nam : Entity_Id) 1922 is 1923 Pack : constant Entity_Id := Entity (Original_Node (Nam)); 1924 Item : Node_Id; 1925 Par : Node_Id; 1926 1927 begin 1928 Item := First (Context_Items (Parent (N))); 1929 1930 while Present (Item) 1931 and then Item /= N 1932 loop 1933 if Nkind (Item) = N_With_Clause 1934 and then Entity (Name (Item)) = Pack 1935 then 1936 Par := Nam; 1937 1938 -- Find root library unit in with_clause. 1939 1940 while Nkind (Par) = N_Expanded_Name loop 1941 Par := Prefix (Par); 1942 end loop; 1943 1944 if Is_Child_Unit (Entity (Original_Node (Par))) then 1945 Error_Msg_NE 1946 ("& is not directly visible", Par, Entity (Par)); 1947 else 1948 return; 1949 end if; 1950 end if; 1951 1952 Next (Item); 1953 end loop; 1954 1955 -- On exit, package is not mentioned in a previous with_clause. 1956 -- Check if its prefix is. 1957 1958 if Nkind (Nam) = N_Expanded_Name then 1959 Check_In_Previous_With_Clause (N, Prefix (Nam)); 1960 1961 elsif Pack /= Any_Id then 1962 Error_Msg_NE ("& is not visible", Nam, Pack); 1963 end if; 1964 end Check_In_Previous_With_Clause; 1965 1966 --------------------------------- 1967 -- Check_Library_Unit_Renaming -- 1968 --------------------------------- 1969 1970 procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id) is 1971 New_E : Entity_Id; 1972 1973 begin 1974 if Nkind (Parent (N)) /= N_Compilation_Unit then 1975 return; 1976 1977 elsif Scope (Old_E) /= Standard_Standard 1978 and then not Is_Child_Unit (Old_E) 1979 then 1980 Error_Msg_N ("renamed unit must be a library unit", Name (N)); 1981 1982 elsif Present (Parent_Spec (N)) 1983 and then Nkind (Unit (Parent_Spec (N))) = N_Generic_Package_Declaration 1984 and then not Is_Child_Unit (Old_E) 1985 then 1986 Error_Msg_N 1987 ("renamed unit must be a child unit of generic parent", Name (N)); 1988 1989 elsif Nkind (N) in N_Generic_Renaming_Declaration 1990 and then Nkind (Name (N)) = N_Expanded_Name 1991 and then Is_Generic_Instance (Entity (Prefix (Name (N)))) 1992 and then Is_Generic_Unit (Old_E) 1993 then 1994 Error_Msg_N 1995 ("renamed generic unit must be a library unit", Name (N)); 1996 1997 elsif Ekind (Old_E) = E_Package 1998 or else Ekind (Old_E) = E_Generic_Package 1999 then 2000 -- Inherit categorization flags 2001 2002 New_E := Defining_Entity (N); 2003 Set_Is_Pure (New_E, Is_Pure (Old_E)); 2004 Set_Is_Preelaborated (New_E, Is_Preelaborated (Old_E)); 2005 Set_Is_Remote_Call_Interface (New_E, 2006 Is_Remote_Call_Interface (Old_E)); 2007 Set_Is_Remote_Types (New_E, Is_Remote_Types (Old_E)); 2008 Set_Is_Shared_Passive (New_E, Is_Shared_Passive (Old_E)); 2009 end if; 2010 end Check_Library_Unit_Renaming; 2011 2012 --------------- 2013 -- End_Scope -- 2014 --------------- 2015 2016 procedure End_Scope is 2017 Id : Entity_Id; 2018 Prev : Entity_Id; 2019 Outer : Entity_Id; 2020 2021 begin 2022 Id := First_Entity (Current_Scope); 2023 2024 while Present (Id) loop 2025 -- An entity in the current scope is not necessarily the first one 2026 -- on its homonym chain. Find its predecessor if any, 2027 -- If it is an internal entity, it will not be in the visibility 2028 -- chain altogether, and there is nothing to unchain. 2029 2030 if Id /= Current_Entity (Id) then 2031 Prev := Current_Entity (Id); 2032 while Present (Prev) 2033 and then Present (Homonym (Prev)) 2034 and then Homonym (Prev) /= Id 2035 loop 2036 Prev := Homonym (Prev); 2037 end loop; 2038 2039 -- Skip to end of loop if Id is not in the visibility chain 2040 2041 if No (Prev) or else Homonym (Prev) /= Id then 2042 goto Next_Ent; 2043 end if; 2044 2045 else 2046 Prev := Empty; 2047 end if; 2048 2049 Outer := Homonym (Id); 2050 Set_Is_Immediately_Visible (Id, False); 2051 2052 while Present (Outer) and then Scope (Outer) = Current_Scope loop 2053 Outer := Homonym (Outer); 2054 end loop; 2055 2056 -- Reset homonym link of other entities, but do not modify link 2057 -- between entities in current scope, so that the back-end can have 2058 -- a proper count of local overloadings. 2059 2060 if No (Prev) then 2061 Set_Name_Entity_Id (Chars (Id), Outer); 2062 2063 elsif Scope (Prev) /= Scope (Id) then 2064 Set_Homonym (Prev, Outer); 2065 end if; 2066 2067 <<Next_Ent>> 2068 Next_Entity (Id); 2069 end loop; 2070 2071 -- If the scope generated freeze actions, place them before the 2072 -- current declaration and analyze them. Type declarations and 2073 -- the bodies of initialization procedures can generate such nodes. 2074 -- We follow the parent chain until we reach a list node, which is 2075 -- the enclosing list of declarations. If the list appears within 2076 -- a protected definition, move freeze nodes outside the protected 2077 -- type altogether. 2078 2079 if Present 2080 (Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions) 2081 then 2082 declare 2083 Decl : Node_Id; 2084 L : constant List_Id := Scope_Stack.Table 2085 (Scope_Stack.Last).Pending_Freeze_Actions; 2086 2087 begin 2088 if Is_Itype (Current_Scope) then 2089 Decl := Associated_Node_For_Itype (Current_Scope); 2090 else 2091 Decl := Parent (Current_Scope); 2092 end if; 2093 2094 Pop_Scope; 2095 2096 while not (Is_List_Member (Decl)) 2097 or else Nkind (Parent (Decl)) = N_Protected_Definition 2098 or else Nkind (Parent (Decl)) = N_Task_Definition 2099 loop 2100 Decl := Parent (Decl); 2101 end loop; 2102 2103 Insert_List_Before_And_Analyze (Decl, L); 2104 end; 2105 2106 else 2107 Pop_Scope; 2108 end if; 2109 2110 end End_Scope; 2111 2112 --------------------- 2113 -- End_Use_Clauses -- 2114 --------------------- 2115 2116 procedure End_Use_Clauses (Clause : Node_Id) is 2117 U : Node_Id; 2118 2119 begin 2120 -- Remove Use_Type clauses first, because they affect the 2121 -- visibility of operators in subsequent used packages. 2122 2123 U := Clause; 2124 while Present (U) loop 2125 if Nkind (U) = N_Use_Type_Clause then 2126 End_Use_Type (U); 2127 end if; 2128 2129 Next_Use_Clause (U); 2130 end loop; 2131 2132 U := Clause; 2133 while Present (U) loop 2134 if Nkind (U) = N_Use_Package_Clause then 2135 End_Use_Package (U); 2136 end if; 2137 2138 Next_Use_Clause (U); 2139 end loop; 2140 end End_Use_Clauses; 2141 2142 --------------------- 2143 -- End_Use_Package -- 2144 --------------------- 2145 2146 procedure End_Use_Package (N : Node_Id) is 2147 Pack_Name : Node_Id; 2148 Pack : Entity_Id; 2149 Id : Entity_Id; 2150 Elmt : Elmt_Id; 2151 2152 function Is_Primitive_Operator 2153 (Op : Entity_Id; 2154 F : Entity_Id) 2155 return Boolean; 2156 -- Check whether Op is a primitive operator of a use-visible type 2157 2158 --------------------------- 2159 -- Is_Primitive_Operator -- 2160 --------------------------- 2161 2162 function Is_Primitive_Operator 2163 (Op : Entity_Id; 2164 F : Entity_Id) 2165 return Boolean 2166 is 2167 T : constant Entity_Id := Etype (F); 2168 2169 begin 2170 return In_Use (T) 2171 and then Scope (T) = Scope (Op); 2172 end Is_Primitive_Operator; 2173 2174 -- Start of processing for End_Use_Package 2175 2176 begin 2177 Pack_Name := First (Names (N)); 2178 2179 while Present (Pack_Name) loop 2180 Pack := Entity (Pack_Name); 2181 2182 if Ekind (Pack) = E_Package then 2183 2184 if In_Open_Scopes (Pack) then 2185 null; 2186 2187 elsif not Redundant_Use (Pack_Name) then 2188 Set_In_Use (Pack, False); 2189 Id := First_Entity (Pack); 2190 2191 while Present (Id) loop 2192 2193 -- Preserve use-visibility of operators that are primitive 2194 -- operators of a type that is use_visible through an active 2195 -- use_type clause. 2196 2197 if Nkind (Id) = N_Defining_Operator_Symbol 2198 and then 2199 (Is_Primitive_Operator (Id, First_Formal (Id)) 2200 or else 2201 (Present (Next_Formal (First_Formal (Id))) 2202 and then 2203 Is_Primitive_Operator 2204 (Id, Next_Formal (First_Formal (Id))))) 2205 then 2206 null; 2207 2208 else 2209 Set_Is_Potentially_Use_Visible (Id, False); 2210 end if; 2211 2212 if Is_Private_Type (Id) 2213 and then Present (Full_View (Id)) 2214 then 2215 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 2216 end if; 2217 2218 Next_Entity (Id); 2219 end loop; 2220 2221 if Present (Renamed_Object (Pack)) then 2222 Set_In_Use (Renamed_Object (Pack), False); 2223 end if; 2224 2225 if Chars (Pack) = Name_System 2226 and then Scope (Pack) = Standard_Standard 2227 and then Present_System_Aux 2228 then 2229 Id := First_Entity (System_Aux_Id); 2230 2231 while Present (Id) loop 2232 Set_Is_Potentially_Use_Visible (Id, False); 2233 2234 if Is_Private_Type (Id) 2235 and then Present (Full_View (Id)) 2236 then 2237 Set_Is_Potentially_Use_Visible (Full_View (Id), False); 2238 end if; 2239 2240 Next_Entity (Id); 2241 end loop; 2242 2243 Set_In_Use (System_Aux_Id, False); 2244 end if; 2245 2246 else 2247 Set_Redundant_Use (Pack_Name, False); 2248 end if; 2249 2250 end if; 2251 2252 Next (Pack_Name); 2253 end loop; 2254 2255 if Present (Hidden_By_Use_Clause (N)) then 2256 Elmt := First_Elmt (Hidden_By_Use_Clause (N)); 2257 2258 while Present (Elmt) loop 2259 Set_Is_Immediately_Visible (Node (Elmt)); 2260 Next_Elmt (Elmt); 2261 end loop; 2262 2263 Set_Hidden_By_Use_Clause (N, No_Elist); 2264 end if; 2265 end End_Use_Package; 2266 2267 ------------------ 2268 -- End_Use_Type -- 2269 ------------------ 2270 2271 procedure End_Use_Type (N : Node_Id) is 2272 Id : Entity_Id; 2273 Op_List : Elist_Id; 2274 Elmt : Elmt_Id; 2275 T : Entity_Id; 2276 2277 begin 2278 Id := First (Subtype_Marks (N)); 2279 2280 while Present (Id) loop 2281 2282 -- A call to rtsfind may occur while analyzing a use_type clause, 2283 -- in which case the type marks are not resolved yet, and there is 2284 -- nothing to remove. 2285 2286 if not Is_Entity_Name (Id) 2287 or else No (Entity (Id)) 2288 then 2289 goto Continue; 2290 end if; 2291 2292 T := Entity (Id); 2293 2294 if T = Any_Type then 2295 null; 2296 2297 -- Note that the use_Type clause may mention a subtype of the 2298 -- type whose primitive operations have been made visible. Here 2299 -- as elsewhere, it is the base type that matters for visibility. 2300 2301 elsif In_Open_Scopes (Scope (Base_Type (T))) then 2302 null; 2303 2304 elsif not Redundant_Use (Id) then 2305 Set_In_Use (T, False); 2306 Set_In_Use (Base_Type (T), False); 2307 Op_List := Collect_Primitive_Operations (T); 2308 Elmt := First_Elmt (Op_List); 2309 2310 while Present (Elmt) loop 2311 2312 if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then 2313 Set_Is_Potentially_Use_Visible (Node (Elmt), False); 2314 end if; 2315 2316 Next_Elmt (Elmt); 2317 end loop; 2318 end if; 2319 2320 <<Continue>> 2321 Next (Id); 2322 end loop; 2323 end End_Use_Type; 2324 2325 ---------------------- 2326 -- Find_Direct_Name -- 2327 ---------------------- 2328 2329 procedure Find_Direct_Name (N : Node_Id) is 2330 E : Entity_Id; 2331 E2 : Entity_Id; 2332 Msg : Boolean; 2333 2334 Inst : Entity_Id := Empty; 2335 -- Enclosing instance, if any. 2336 2337 Homonyms : Entity_Id; 2338 -- Saves start of homonym chain 2339 2340 Nvis_Entity : Boolean; 2341 -- Set True to indicate that at there is at least one entity on the 2342 -- homonym chain which, while not visible, is visible enough from the 2343 -- user point of view to warrant an error message of "not visible" 2344 -- rather than undefined. 2345 2346 function From_Actual_Package (E : Entity_Id) return Boolean; 2347 -- Returns true if the entity is declared in a package that is 2348 -- an actual for a formal package of the current instance. Such an 2349 -- entity requires special handling because it may be use-visible 2350 -- but hides directly visible entities defined outside the instance. 2351 2352 function Known_But_Invisible (E : Entity_Id) return Boolean; 2353 -- This function determines whether the entity E (which is not 2354 -- visible) can reasonably be considered to be known to the writer 2355 -- of the reference. This is a heuristic test, used only for the 2356 -- purposes of figuring out whether we prefer to complain that an 2357 -- entity is undefined or invisible (and identify the declaration 2358 -- of the invisible entity in the latter case). The point here is 2359 -- that we don't want to complain that something is invisible and 2360 -- then point to something entirely mysterious to the writer. 2361 2362 procedure Nvis_Messages; 2363 -- Called if there are no visible entries for N, but there is at least 2364 -- one non-directly visible, or hidden declaration. This procedure 2365 -- outputs an appropriate set of error messages. 2366 2367 procedure Undefined (Nvis : Boolean); 2368 -- This function is called if the current node has no corresponding 2369 -- visible entity or entities. The value set in Msg indicates whether 2370 -- an error message was generated (multiple error messages for the 2371 -- same variable are generally suppressed, see body for details). 2372 -- Msg is True if an error message was generated, False if not. This 2373 -- value is used by the caller to determine whether or not to output 2374 -- additional messages where appropriate. The parameter is set False 2375 -- to get the message "X is undefined", and True to get the message 2376 -- "X is not visible". 2377 2378 ------------------------- 2379 -- From_Actual_Package -- 2380 ------------------------- 2381 2382 function From_Actual_Package (E : Entity_Id) return Boolean is 2383 Scop : constant Entity_Id := Scope (E); 2384 Act : Entity_Id; 2385 2386 begin 2387 if not In_Instance then 2388 return False; 2389 else 2390 Inst := Current_Scope; 2391 2392 while Present (Inst) 2393 and then Ekind (Inst) /= E_Package 2394 and then not Is_Generic_Instance (Inst) 2395 loop 2396 Inst := Scope (Inst); 2397 end loop; 2398 2399 if No (Inst) then 2400 return False; 2401 end if; 2402 2403 Act := First_Entity (Inst); 2404 2405 while Present (Act) loop 2406 if Ekind (Act) = E_Package then 2407 2408 -- Check for end of actuals list 2409 2410 if Renamed_Object (Act) = Inst then 2411 return False; 2412 2413 elsif Present (Associated_Formal_Package (Act)) 2414 and then Renamed_Object (Act) = Scop 2415 then 2416 -- Entity comes from (instance of) formal package 2417 2418 return True; 2419 2420 else 2421 Next_Entity (Act); 2422 end if; 2423 2424 else 2425 Next_Entity (Act); 2426 end if; 2427 end loop; 2428 2429 return False; 2430 end if; 2431 end From_Actual_Package; 2432 2433 ------------------------- 2434 -- Known_But_Invisible -- 2435 ------------------------- 2436 2437 function Known_But_Invisible (E : Entity_Id) return Boolean is 2438 Fname : File_Name_Type; 2439 2440 begin 2441 -- Entities in Standard are always considered to be known 2442 2443 if Sloc (E) <= Standard_Location then 2444 return True; 2445 2446 -- An entity that does not come from source is always considered 2447 -- to be unknown, since it is an artifact of code expansion. 2448 2449 elsif not Comes_From_Source (E) then 2450 return False; 2451 2452 -- In gnat internal mode, we consider all entities known 2453 2454 elsif GNAT_Mode then 2455 return True; 2456 end if; 2457 2458 -- Here we have an entity that is not from package Standard, and 2459 -- which comes from Source. See if it comes from an internal file. 2460 2461 Fname := Unit_File_Name (Get_Source_Unit (E)); 2462 2463 -- Case of from internal file 2464 2465 if Is_Internal_File_Name (Fname) then 2466 2467 -- Private part entities in internal files are never considered 2468 -- to be known to the writer of normal application code. 2469 2470 if Is_Hidden (E) then 2471 return False; 2472 end if; 2473 2474 -- Entities from System packages other than System and 2475 -- System.Storage_Elements are not considered to be known. 2476 -- System.Auxxxx files are also considered known to the user. 2477 2478 -- Should refine this at some point to generally distinguish 2479 -- between known and unknown internal files ??? 2480 2481 Get_Name_String (Fname); 2482 2483 return 2484 Name_Len < 2 2485 or else 2486 Name_Buffer (1 .. 2) /= "s-" 2487 or else 2488 Name_Buffer (3 .. 8) = "stoele" 2489 or else 2490 Name_Buffer (3 .. 5) = "aux"; 2491 2492 -- If not an internal file, then entity is definitely known, 2493 -- even if it is in a private part (the message generated will 2494 -- note that it is in a private part) 2495 2496 else 2497 return True; 2498 end if; 2499 end Known_But_Invisible; 2500 2501 ------------------- 2502 -- Nvis_Messages -- 2503 ------------------- 2504 2505 procedure Nvis_Messages is 2506 Ent : Entity_Id; 2507 Hidden : Boolean := False; 2508 2509 begin 2510 Undefined (Nvis => True); 2511 2512 if Msg then 2513 2514 -- First loop does hidden declarations 2515 2516 Ent := Homonyms; 2517 while Present (Ent) loop 2518 if Is_Potentially_Use_Visible (Ent) then 2519 2520 if not Hidden then 2521 Error_Msg_N ("multiple use clauses cause hiding!", N); 2522 Hidden := True; 2523 end if; 2524 2525 Error_Msg_Sloc := Sloc (Ent); 2526 Error_Msg_N ("hidden declaration#!", N); 2527 end if; 2528 2529 Ent := Homonym (Ent); 2530 end loop; 2531 2532 -- If we found hidden declarations, then that's enough, don't 2533 -- bother looking for non-visible declarations as well. 2534 2535 if Hidden then 2536 return; 2537 end if; 2538 2539 -- Second loop does non-directly visible declarations 2540 2541 Ent := Homonyms; 2542 while Present (Ent) loop 2543 if not Is_Potentially_Use_Visible (Ent) then 2544 2545 -- Do not bother the user with unknown entities 2546 2547 if not Known_But_Invisible (Ent) then 2548 goto Continue; 2549 end if; 2550 2551 Error_Msg_Sloc := Sloc (Ent); 2552 2553 -- Output message noting that there is a non-visible 2554 -- declaration, distinguishing the private part case. 2555 2556 if Is_Hidden (Ent) then 2557 Error_Msg_N ("non-visible (private) declaration#!", N); 2558 else 2559 Error_Msg_N ("non-visible declaration#!", N); 2560 2561 if Is_Compilation_Unit (Ent) 2562 and then 2563 Nkind (Parent (Parent (N))) = N_Use_Package_Clause 2564 then 2565 Error_Msg_NE 2566 ("\possibly missing with_clause for&", N, Ent); 2567 end if; 2568 end if; 2569 2570 -- Set entity and its containing package as referenced. We 2571 -- can't be sure of this, but this seems a better choice 2572 -- to avoid unused entity messages. 2573 2574 if Comes_From_Source (Ent) then 2575 Set_Referenced (Ent); 2576 Set_Referenced (Cunit_Entity (Get_Source_Unit (Ent))); 2577 end if; 2578 end if; 2579 2580 <<Continue>> 2581 Ent := Homonym (Ent); 2582 end loop; 2583 2584 end if; 2585 end Nvis_Messages; 2586 2587 --------------- 2588 -- Undefined -- 2589 --------------- 2590 2591 procedure Undefined (Nvis : Boolean) is 2592 Emsg : Error_Msg_Id; 2593 2594 begin 2595 -- We should never find an undefined internal name. If we do, then 2596 -- see if we have previous errors. If so, ignore on the grounds that 2597 -- it is probably a cascaded message (e.g. a block label from a badly 2598 -- formed block). If no previous errors, then we have a real internal 2599 -- error of some kind so raise an exception. 2600 2601 if Is_Internal_Name (Chars (N)) then 2602 if Total_Errors_Detected /= 0 then 2603 return; 2604 else 2605 raise Program_Error; 2606 end if; 2607 end if; 2608 2609 -- A very specialized error check, if the undefined variable is 2610 -- a case tag, and the case type is an enumeration type, check 2611 -- for a possible misspelling, and if so, modify the identifier 2612 2613 -- Named aggregate should also be handled similarly ??? 2614 2615 if Nkind (N) = N_Identifier 2616 and then Nkind (Parent (N)) = N_Case_Statement_Alternative 2617 then 2618 Get_Name_String (Chars (N)); 2619 2620 declare 2621 Case_Str : constant String := Name_Buffer (1 .. Name_Len); 2622 Case_Stm : constant Node_Id := Parent (Parent (N)); 2623 Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm)); 2624 2625 Lit : Node_Id; 2626 2627 begin 2628 if Is_Enumeration_Type (Case_Typ) 2629 and then Case_Typ /= Standard_Character 2630 and then Case_Typ /= Standard_Wide_Character 2631 then 2632 Lit := First_Literal (Case_Typ); 2633 Get_Name_String (Chars (Lit)); 2634 2635 if Chars (Lit) /= Chars (N) 2636 and then Is_Bad_Spelling_Of 2637 (Case_Str, Name_Buffer (1 .. Name_Len)) 2638 then 2639 Error_Msg_Node_2 := Lit; 2640 Error_Msg_N 2641 ("& is undefined, assume misspelling of &", N); 2642 Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); 2643 return; 2644 end if; 2645 2646 Lit := Next_Literal (Lit); 2647 end if; 2648 end; 2649 end if; 2650 2651 -- Normal processing 2652 2653 Set_Entity (N, Any_Id); 2654 Set_Etype (N, Any_Type); 2655 2656 -- We use the table Urefs to keep track of entities for which we 2657 -- have issued errors for undefined references. Multiple errors 2658 -- for a single name are normally suppressed, however we modify 2659 -- the error message to alert the programmer to this effect. 2660 2661 for J in Urefs.First .. Urefs.Last loop 2662 if Chars (N) = Chars (Urefs.Table (J).Node) then 2663 if Urefs.Table (J).Err /= No_Error_Msg 2664 and then Sloc (N) /= Urefs.Table (J).Loc 2665 then 2666 Error_Msg_Node_1 := Urefs.Table (J).Node; 2667 2668 if Urefs.Table (J).Nvis then 2669 Change_Error_Text (Urefs.Table (J).Err, 2670 "& is not visible (more references follow)"); 2671 else 2672 Change_Error_Text (Urefs.Table (J).Err, 2673 "& is undefined (more references follow)"); 2674 end if; 2675 2676 Urefs.Table (J).Err := No_Error_Msg; 2677 end if; 2678 2679 -- Although we will set Msg False, and thus suppress the 2680 -- message, we also set Error_Posted True, to avoid any 2681 -- cascaded messages resulting from the undefined reference. 2682 2683 Msg := False; 2684 Set_Error_Posted (N, True); 2685 return; 2686 end if; 2687 end loop; 2688 2689 -- If entry not found, this is first undefined occurrence 2690 2691 if Nvis then 2692 Error_Msg_N ("& is not visible!", N); 2693 Emsg := Get_Msg_Id; 2694 2695 else 2696 Error_Msg_N ("& is undefined!", N); 2697 Emsg := Get_Msg_Id; 2698 2699 -- A very bizarre special check, if the undefined identifier 2700 -- is put or put_line, then add a special error message (since 2701 -- this is a very common error for beginners to make). 2702 2703 if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then 2704 Error_Msg_N ("\possible missing with of 'Text_'I'O!", N); 2705 end if; 2706 2707 -- Now check for possible misspellings 2708 2709 Get_Name_String (Chars (N)); 2710 2711 declare 2712 E : Entity_Id; 2713 Ematch : Entity_Id := Empty; 2714 2715 Last_Name_Id : constant Name_Id := 2716 Name_Id (Nat (First_Name_Id) + 2717 Name_Entries_Count - 1); 2718 2719 S : constant String (1 .. Name_Len) := 2720 Name_Buffer (1 .. Name_Len); 2721 2722 begin 2723 for N in First_Name_Id .. Last_Name_Id loop 2724 E := Get_Name_Entity_Id (N); 2725 2726 if Present (E) 2727 and then (Is_Immediately_Visible (E) 2728 or else 2729 Is_Potentially_Use_Visible (E)) 2730 then 2731 Get_Name_String (N); 2732 2733 if Is_Bad_Spelling_Of 2734 (Name_Buffer (1 .. Name_Len), S) 2735 then 2736 Ematch := E; 2737 exit; 2738 end if; 2739 end if; 2740 end loop; 2741 2742 if Present (Ematch) then 2743 Error_Msg_NE ("\possible misspelling of&", N, Ematch); 2744 end if; 2745 end; 2746 end if; 2747 2748 -- Make entry in undefined references table unless the full 2749 -- errors switch is set, in which case by refraining from 2750 -- generating the table entry, we guarantee that we get an 2751 -- error message for every undefined reference. 2752 2753 if not All_Errors_Mode then 2754 Urefs.Increment_Last; 2755 Urefs.Table (Urefs.Last).Node := N; 2756 Urefs.Table (Urefs.Last).Err := Emsg; 2757 Urefs.Table (Urefs.Last).Nvis := Nvis; 2758 Urefs.Table (Urefs.Last).Loc := Sloc (N); 2759 end if; 2760 2761 Msg := True; 2762 end Undefined; 2763 2764 -- Start of processing for Find_Direct_Name 2765 2766 begin 2767 -- If the entity pointer is already set, this is an internal node, or 2768 -- a node that is analyzed more than once, after a tree modification. 2769 -- In such a case there is no resolution to perform, just set the type. 2770 2771 if Present (Entity (N)) then 2772 if Is_Type (Entity (N)) then 2773 Set_Etype (N, Entity (N)); 2774 2775 else 2776 declare 2777 Entyp : constant Entity_Id := Etype (Entity (N)); 2778 2779 begin 2780 -- One special case here. If the Etype field is already set, 2781 -- and references the packed array type corresponding to the 2782 -- etype of the referenced entity, then leave it alone. This 2783 -- happens for trees generated from Exp_Pakd, where expressions 2784 -- can be deliberately "mis-typed" to the packed array type. 2785 2786 if Is_Array_Type (Entyp) 2787 and then Is_Packed (Entyp) 2788 and then Present (Etype (N)) 2789 and then Etype (N) = Packed_Array_Type (Entyp) 2790 then 2791 null; 2792 2793 -- If not that special case, then just reset the Etype 2794 2795 else 2796 Set_Etype (N, Etype (Entity (N))); 2797 end if; 2798 end; 2799 end if; 2800 2801 return; 2802 end if; 2803 2804 -- Here if Entity pointer was not set, we need full visibility analysis 2805 -- First we generate debugging output if the debug E flag is set. 2806 2807 if Debug_Flag_E then 2808 Write_Str ("Looking for "); 2809 Write_Name (Chars (N)); 2810 Write_Eol; 2811 end if; 2812 2813 Homonyms := Current_Entity (N); 2814 Nvis_Entity := False; 2815 2816 E := Homonyms; 2817 while Present (E) loop 2818 2819 -- If entity is immediately visible or potentially use 2820 -- visible, then process the entity and we are done. 2821 2822 if Is_Immediately_Visible (E) then 2823 goto Immediately_Visible_Entity; 2824 2825 elsif Is_Potentially_Use_Visible (E) then 2826 goto Potentially_Use_Visible_Entity; 2827 2828 -- Note if a known but invisible entity encountered 2829 2830 elsif Known_But_Invisible (E) then 2831 Nvis_Entity := True; 2832 end if; 2833 2834 -- Move to next entity in chain and continue search 2835 2836 E := Homonym (E); 2837 end loop; 2838 2839 -- If no entries on homonym chain that were potentially visible, 2840 -- and no entities reasonably considered as non-visible, then 2841 -- we have a plain undefined reference, with no additional 2842 -- explanation required! 2843 2844 if not Nvis_Entity then 2845 Undefined (Nvis => False); 2846 2847 -- Otherwise there is at least one entry on the homonym chain that 2848 -- is reasonably considered as being known and non-visible. 2849 2850 else 2851 Nvis_Messages; 2852 end if; 2853 2854 return; 2855 2856 -- Processing for a potentially use visible entry found. We must search 2857 -- the rest of the homonym chain for two reasons. First, if there is a 2858 -- directly visible entry, then none of the potentially use-visible 2859 -- entities are directly visible (RM 8.4(10)). Second, we need to check 2860 -- for the case of multiple potentially use-visible entries hiding one 2861 -- another and as a result being non-directly visible (RM 8.4(11)). 2862 2863 <<Potentially_Use_Visible_Entity>> declare 2864 Only_One_Visible : Boolean := True; 2865 All_Overloadable : Boolean := Is_Overloadable (E); 2866 2867 begin 2868 E2 := Homonym (E); 2869 2870 while Present (E2) loop 2871 if Is_Immediately_Visible (E2) then 2872 2873 -- If the use-visible entity comes from the actual for a 2874 -- formal package, it hides a directly visible entity from 2875 -- outside the instance. 2876 2877 if From_Actual_Package (E) 2878 and then Scope_Depth (E2) < Scope_Depth (Inst) 2879 then 2880 goto Found; 2881 else 2882 E := E2; 2883 goto Immediately_Visible_Entity; 2884 end if; 2885 2886 elsif Is_Potentially_Use_Visible (E2) then 2887 Only_One_Visible := False; 2888 All_Overloadable := All_Overloadable and Is_Overloadable (E2); 2889 end if; 2890 2891 E2 := Homonym (E2); 2892 end loop; 2893 2894 -- On falling through this loop, we have checked that there are no 2895 -- immediately visible entities. Only_One_Visible is set if exactly 2896 -- one potentially use visible entity exists. All_Overloadable is 2897 -- set if all the potentially use visible entities are overloadable. 2898 -- The condition for legality is that either there is one potentially 2899 -- use visible entity, or if there is more than one, then all of them 2900 -- are overloadable. 2901 2902 if Only_One_Visible or All_Overloadable then 2903 goto Found; 2904 2905 -- If there is more than one potentially use-visible entity and at 2906 -- least one of them non-overloadable, we have an error (RM 8.4(11). 2907 -- Note that E points to the first such entity on the homonym list. 2908 -- Special case: if one of the entities is declared in an actual 2909 -- package, it was visible in the generic, and takes precedence over 2910 -- other entities that are potentially use-visible. Same if it is 2911 -- declared in a local instantiation of the current instance. 2912 2913 else 2914 if In_Instance then 2915 Inst := Current_Scope; 2916 2917 -- Find current instance. 2918 2919 while Present (Inst) 2920 and then Inst /= Standard_Standard 2921 loop 2922 if Is_Generic_Instance (Inst) then 2923 exit; 2924 end if; 2925 2926 Inst := Scope (Inst); 2927 end loop; 2928 2929 E2 := E; 2930 2931 while Present (E2) loop 2932 if From_Actual_Package (E2) 2933 or else 2934 (Is_Generic_Instance (Scope (E2)) 2935 and then Scope_Depth (Scope (E2)) > Scope_Depth (Inst)) 2936 then 2937 E := E2; 2938 goto Found; 2939 end if; 2940 2941 E2 := Homonym (E2); 2942 end loop; 2943 2944 Nvis_Messages; 2945 return; 2946 2947 else 2948 Nvis_Messages; 2949 return; 2950 end if; 2951 end if; 2952 end; 2953 2954 -- Come here with E set to the first immediately visible entity on 2955 -- the homonym chain. This is the one we want unless there is another 2956 -- immediately visible entity further on in the chain for a more 2957 -- inner scope (RM 8.3(8)). 2958 2959 <<Immediately_Visible_Entity>> declare 2960 Level : Int; 2961 Scop : Entity_Id; 2962 2963 begin 2964 -- Find scope level of initial entity. When compiling through 2965 -- Rtsfind, the previous context is not completely invisible, and 2966 -- an outer entity may appear on the chain, whose scope is below 2967 -- the entry for Standard that delimits the current scope stack. 2968 -- Indicate that the level for this spurious entry is outside of 2969 -- the current scope stack. 2970 2971 Level := Scope_Stack.Last; 2972 loop 2973 Scop := Scope_Stack.Table (Level).Entity; 2974 exit when Scop = Scope (E); 2975 Level := Level - 1; 2976 exit when Scop = Standard_Standard; 2977 end loop; 2978 2979 -- Now search remainder of homonym chain for more inner entry 2980 -- If the entity is Standard itself, it has no scope, and we 2981 -- compare it with the stack entry directly. 2982 2983 E2 := Homonym (E); 2984 while Present (E2) loop 2985 if Is_Immediately_Visible (E2) then 2986 for J in Level + 1 .. Scope_Stack.Last loop 2987 if Scope_Stack.Table (J).Entity = Scope (E2) 2988 or else Scope_Stack.Table (J).Entity = E2 2989 then 2990 Level := J; 2991 E := E2; 2992 exit; 2993 end if; 2994 end loop; 2995 end if; 2996 2997 E2 := Homonym (E2); 2998 end loop; 2999 3000 -- At the end of that loop, E is the innermost immediately 3001 -- visible entity, so we are all set. 3002 end; 3003 3004 -- Come here with entity found, and stored in E 3005 3006 <<Found>> begin 3007 3008 if Comes_From_Source (N) 3009 and then Is_Remote_Access_To_Subprogram_Type (E) 3010 and then Expander_Active 3011 then 3012 Rewrite (N, 3013 New_Occurrence_Of (Equivalent_Type (E), Sloc (N))); 3014 return; 3015 end if; 3016 3017 Set_Entity (N, E); 3018 -- Why no Style_Check here??? 3019 3020 if Is_Type (E) then 3021 Set_Etype (N, E); 3022 else 3023 Set_Etype (N, Get_Full_View (Etype (E))); 3024 end if; 3025 3026 if Debug_Flag_E then 3027 Write_Str (" found "); 3028 Write_Entity_Info (E, " "); 3029 end if; 3030 3031 -- If the Ekind of the entity is Void, it means that all homonyms 3032 -- are hidden from all visibility (RM 8.3(5,14-20)). However, this 3033 -- test is skipped if the current scope is a record and the name is 3034 -- a pragma argument expression (case of Atomic and Volatile pragmas 3035 -- and possibly other similar pragmas added later, which are allowed 3036 -- to reference components in the current record). 3037 3038 if Ekind (E) = E_Void 3039 and then 3040 (not Is_Record_Type (Current_Scope) 3041 or else Nkind (Parent (N)) /= N_Pragma_Argument_Association) 3042 then 3043 Premature_Usage (N); 3044 3045 -- If the entity is overloadable, collect all interpretations 3046 -- of the name for subsequent overload resolution. We optimize 3047 -- a bit here to do this only if we have an overloadable entity 3048 -- that is not on its own on the homonym chain. 3049 3050 elsif Is_Overloadable (E) 3051 and then (Present (Homonym (E)) or else Current_Entity (N) /= E) 3052 then 3053 Collect_Interps (N); 3054 3055 -- If no homonyms were visible, the entity is unambiguous. 3056 3057 if not Is_Overloaded (N) then 3058 Generate_Reference (E, N); 3059 end if; 3060 3061 -- Case of non-overloadable entity, set the entity providing that 3062 -- we do not have the case of a discriminant reference within a 3063 -- default expression. Such references are replaced with the 3064 -- corresponding discriminal, which is the formal corresponding to 3065 -- to the discriminant in the initialization procedure. 3066 3067 else 3068 -- Entity is unambiguous, indicate that it is referenced here 3069 -- One slightly odd case is that we do not want to set the 3070 -- Referenced flag if the entity is a label, and the identifier 3071 -- is the label in the source, since this is not a reference 3072 -- from the point of view of the user 3073 3074 if Nkind (Parent (N)) = N_Label then 3075 declare 3076 R : constant Boolean := Referenced (E); 3077 3078 begin 3079 Generate_Reference (E, N); 3080 Set_Referenced (E, R); 3081 end; 3082 3083 -- Normal case, not a label. Generate reference. 3084 3085 else 3086 Generate_Reference (E, N); 3087 end if; 3088 3089 -- Set Entity, with style check if need be. If this is a 3090 -- discriminant reference, it must be replaced by the 3091 -- corresponding discriminal, that is to say the parameter 3092 -- of the initialization procedure that corresponds to the 3093 -- discriminant. If this replacement is being performed, there 3094 -- is no style check to perform. 3095 3096 -- This replacement must not be done if we are currently 3097 -- processing a generic spec or body, because the discriminal 3098 -- has not been not generated in this case. 3099 3100 if not In_Default_Expression 3101 or else Ekind (E) /= E_Discriminant 3102 or else Inside_A_Generic 3103 then 3104 Set_Entity_With_Style_Check (N, E); 3105 3106 -- The replacement is not done either for a task discriminant that 3107 -- appears in a default expression of an entry parameter. See 3108 -- Expand_Discriminant in exp_ch2 for details on their handling. 3109 3110 elsif Is_Concurrent_Type (Scope (E)) then 3111 declare 3112 P : Node_Id := Parent (N); 3113 3114 begin 3115 while Present (P) 3116 and then Nkind (P) /= N_Parameter_Specification 3117 and then Nkind (P) /= N_Component_Declaration 3118 loop 3119 P := Parent (P); 3120 end loop; 3121 3122 if Present (P) 3123 and then Nkind (P) = N_Parameter_Specification 3124 then 3125 null; 3126 else 3127 Set_Entity (N, Discriminal (E)); 3128 end if; 3129 end; 3130 3131 -- Otherwise, this is a discriminant in a context in which 3132 -- it is a reference to the corresponding parameter of the 3133 -- init proc for the enclosing type. 3134 3135 else 3136 Set_Entity (N, Discriminal (E)); 3137 end if; 3138 end if; 3139 end; 3140 end Find_Direct_Name; 3141 3142 ------------------------ 3143 -- Find_Expanded_Name -- 3144 ------------------------ 3145 3146 -- This routine searches the homonym chain of the entity until it finds 3147 -- an entity declared in the scope denoted by the prefix. If the entity 3148 -- is private, it may nevertheless be immediately visible, if we are in 3149 -- the scope of its declaration. 3150 3151 procedure Find_Expanded_Name (N : Node_Id) is 3152 Selector : constant Node_Id := Selector_Name (N); 3153 Candidate : Entity_Id := Empty; 3154 P_Name : Entity_Id; 3155 O_Name : Entity_Id; 3156 Id : Entity_Id; 3157 3158 begin 3159 P_Name := Entity (Prefix (N)); 3160 O_Name := P_Name; 3161 3162 -- If the prefix is a renamed package, look for the entity 3163 -- in the original package. 3164 3165 if Ekind (P_Name) = E_Package 3166 and then Present (Renamed_Object (P_Name)) 3167 then 3168 P_Name := Renamed_Object (P_Name); 3169 3170 -- Rewrite node with entity field pointing to renamed object 3171 3172 Rewrite (Prefix (N), New_Copy (Prefix (N))); 3173 Set_Entity (Prefix (N), P_Name); 3174 3175 -- If the prefix is an object of a concurrent type, look for 3176 -- the entity in the associated task or protected type. 3177 3178 elsif Is_Concurrent_Type (Etype (P_Name)) then 3179 P_Name := Etype (P_Name); 3180 end if; 3181 3182 Id := Current_Entity (Selector); 3183 3184 while Present (Id) loop 3185 3186 if Scope (Id) = P_Name then 3187 Candidate := Id; 3188 3189 if Is_Child_Unit (Id) then 3190 exit when Is_Visible_Child_Unit (Id) 3191 or else Is_Immediately_Visible (Id); 3192 3193 else 3194 exit when not Is_Hidden (Id) 3195 or else Is_Immediately_Visible (Id); 3196 end if; 3197 end if; 3198 3199 Id := Homonym (Id); 3200 end loop; 3201 3202 if No (Id) 3203 and then (Ekind (P_Name) = E_Procedure 3204 or else 3205 Ekind (P_Name) = E_Function) 3206 and then Is_Generic_Instance (P_Name) 3207 then 3208 -- Expanded name denotes entity in (instance of) generic subprogram. 3209 -- The entity may be in the subprogram instance, or may denote one of 3210 -- the formals, which is declared in the enclosing wrapper package. 3211 3212 P_Name := Scope (P_Name); 3213 Id := Current_Entity (Selector); 3214 3215 while Present (Id) loop 3216 exit when Scope (Id) = P_Name; 3217 Id := Homonym (Id); 3218 end loop; 3219 end if; 3220 3221 if No (Id) or else Chars (Id) /= Chars (Selector) then 3222 3223 Set_Etype (N, Any_Type); 3224 3225 -- If we are looking for an entity defined in System, try to 3226 -- find it in the child package that may have been provided as 3227 -- an extension to System. The Extend_System pragma will have 3228 -- supplied the name of the extension, which may have to be loaded. 3229 3230 if Chars (P_Name) = Name_System 3231 and then Scope (P_Name) = Standard_Standard 3232 and then Present (System_Extend_Unit) 3233 and then Present_System_Aux (N) 3234 then 3235 Set_Entity (Prefix (N), System_Aux_Id); 3236 Find_Expanded_Name (N); 3237 return; 3238 3239 elsif Nkind (Selector) = N_Operator_Symbol 3240 and then Has_Implicit_Operator (N) 3241 then 3242 -- There is an implicit instance of the predefined operator in 3243 -- the given scope. The operator entity is defined in Standard. 3244 -- Has_Implicit_Operator makes the node into an Expanded_Name. 3245 3246 return; 3247 3248 elsif Nkind (Selector) = N_Character_Literal 3249 and then Has_Implicit_Character_Literal (N) 3250 then 3251 -- If there is no literal defined in the scope denoted by the 3252 -- prefix, the literal may belong to (a type derived from) 3253 -- Standard_Character, for which we have no explicit literals. 3254 3255 return; 3256 3257 else 3258 -- If the prefix is a single concurrent object, use its 3259 -- name in the error message, rather than that of the 3260 -- anonymous type. 3261 3262 if Is_Concurrent_Type (P_Name) 3263 and then Is_Internal_Name (Chars (P_Name)) 3264 then 3265 Error_Msg_Node_2 := Entity (Prefix (N)); 3266 else 3267 Error_Msg_Node_2 := P_Name; 3268 end if; 3269 3270 if P_Name = System_Aux_Id then 3271 P_Name := Scope (P_Name); 3272 Set_Entity (Prefix (N), P_Name); 3273 end if; 3274 3275 if Present (Candidate) then 3276 3277 if Is_Child_Unit (Candidate) then 3278 Error_Msg_N 3279 ("missing with_clause for child unit &", Selector); 3280 else 3281 Error_Msg_NE ("& is not a visible entity of&", N, Selector); 3282 end if; 3283 3284 else 3285 -- Within the instantiation of a child unit, the prefix may 3286 -- denote the parent instance, but the selector has the 3287 -- name of the original child. Find whether we are within 3288 -- the corresponding instance, and get the proper entity, which 3289 -- can only be an enclosing scope. 3290 3291 if O_Name /= P_Name 3292 and then In_Open_Scopes (P_Name) 3293 and then Is_Generic_Instance (P_Name) 3294 then 3295 declare 3296 S : Entity_Id := Current_Scope; 3297 P : Entity_Id; 3298 3299 begin 3300 for J in reverse 0 .. Scope_Stack.Last loop 3301 S := Scope_Stack.Table (J).Entity; 3302 3303 exit when S = Standard_Standard; 3304 3305 if Ekind (S) = E_Function 3306 or else Ekind (S) = E_Package 3307 or else Ekind (S) = E_Procedure 3308 then 3309 P := Generic_Parent (Specification 3310 (Unit_Declaration_Node (S))); 3311 3312 if Present (P) 3313 and then Chars (Scope (P)) = Chars (O_Name) 3314 and then Chars (P) = Chars (Selector) 3315 then 3316 Id := S; 3317 goto found; 3318 end if; 3319 end if; 3320 3321 end loop; 3322 end; 3323 end if; 3324 3325 if Chars (P_Name) = Name_Ada 3326 and then Scope (P_Name) = Standard_Standard 3327 then 3328 Error_Msg_Node_2 := Selector; 3329 Error_Msg_NE ("missing with for `&.&`", N, P_Name); 3330 3331 -- If this is a selection from a dummy package, then 3332 -- suppress the error message, of course the entity 3333 -- is missing if the package is missing! 3334 3335 elsif Sloc (Error_Msg_Node_2) = No_Location then 3336 null; 3337 3338 -- Here we have the case of an undefined component 3339 3340 else 3341 3342 Error_Msg_NE ("& not declared in&", N, Selector); 3343 3344 -- Check for misspelling of some entity in prefix. 3345 3346 Id := First_Entity (P_Name); 3347 Get_Name_String (Chars (Selector)); 3348 3349 declare 3350 S : constant String (1 .. Name_Len) := 3351 Name_Buffer (1 .. Name_Len); 3352 begin 3353 while Present (Id) loop 3354 Get_Name_String (Chars (Id)); 3355 if Is_Bad_Spelling_Of 3356 (Name_Buffer (1 .. Name_Len), S) 3357 and then not Is_Internal_Name (Chars (Id)) 3358 then 3359 Error_Msg_NE 3360 ("possible misspelling of&", Selector, Id); 3361 exit; 3362 end if; 3363 3364 Next_Entity (Id); 3365 end loop; 3366 end; 3367 3368 -- Specialize the message if this may be an instantiation 3369 -- of a child unit that was not mentioned in the context. 3370 3371 if Nkind (Parent (N)) = N_Package_Instantiation 3372 and then Is_Generic_Instance (Entity (Prefix (N))) 3373 and then Is_Compilation_Unit 3374 (Generic_Parent (Parent (Entity (Prefix (N))))) 3375 then 3376 Error_Msg_NE 3377 ("\possible missing with clause on child unit&", 3378 N, Selector); 3379 end if; 3380 end if; 3381 end if; 3382 3383 Id := Any_Id; 3384 end if; 3385 end if; 3386 3387 <<found>> 3388 if Comes_From_Source (N) 3389 and then Is_Remote_Access_To_Subprogram_Type (Id) 3390 then 3391 Id := Equivalent_Type (Id); 3392 Set_Chars (Selector, Chars (Id)); 3393 end if; 3394 3395 -- Ada0Y (AI-50217): Check usage of entities in limited withed units 3396 3397 if Ekind (P_Name) = E_Package 3398 and then From_With_Type (P_Name) 3399 then 3400 if From_With_Type (Id) 3401 or else (Ekind (Id) = E_Package and then From_With_Type (Id)) 3402 then 3403 null; 3404 else 3405 Error_Msg_N 3406 ("limited withed package can only be used to access " 3407 & " incomplete types", 3408 N); 3409 end if; 3410 end if; 3411 3412 if Is_Task_Type (P_Name) 3413 and then ((Ekind (Id) = E_Entry 3414 and then Nkind (Parent (N)) /= N_Attribute_Reference) 3415 or else 3416 (Ekind (Id) = E_Entry_Family 3417 and then 3418 Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) 3419 then 3420 -- It is an entry call after all, either to the current task 3421 -- (which will deadlock) or to an enclosing task. 3422 3423 Analyze_Selected_Component (N); 3424 return; 3425 end if; 3426 3427 Change_Selected_Component_To_Expanded_Name (N); 3428 3429 -- Do style check and generate reference, but skip both steps if this 3430 -- entity has homonyms, since we may not have the right homonym set 3431 -- yet. The proper homonym will be set during the resolve phase. 3432 3433 if Has_Homonym (Id) then 3434 Set_Entity (N, Id); 3435 else 3436 Set_Entity_With_Style_Check (N, Id); 3437 Generate_Reference (Id, N); 3438 end if; 3439 3440 if Is_Type (Id) then 3441 Set_Etype (N, Id); 3442 else 3443 Set_Etype (N, Get_Full_View (Etype (Id))); 3444 end if; 3445 3446 -- If the Ekind of the entity is Void, it means that all homonyms 3447 -- are hidden from all visibility (RM 8.3(5,14-20)). 3448 3449 if Ekind (Id) = E_Void then 3450 Premature_Usage (N); 3451 3452 elsif Is_Overloadable (Id) 3453 and then Present (Homonym (Id)) 3454 then 3455 declare 3456 H : Entity_Id := Homonym (Id); 3457 3458 begin 3459 while Present (H) loop 3460 if Scope (H) = Scope (Id) then 3461 Collect_Interps (N); 3462 exit; 3463 end if; 3464 3465 H := Homonym (H); 3466 end loop; 3467 3468 -- If an extension of System is present, collect possible 3469 -- explicit overloadings declared in the extension. 3470 3471 if Chars (P_Name) = Name_System 3472 and then Scope (P_Name) = Standard_Standard 3473 and then Present (System_Extend_Unit) 3474 and then Present_System_Aux (N) 3475 then 3476 H := Current_Entity (Id); 3477 3478 while Present (H) loop 3479 if Scope (H) = System_Aux_Id then 3480 Add_One_Interp (N, H, Etype (H)); 3481 end if; 3482 3483 H := Homonym (H); 3484 end loop; 3485 end if; 3486 end; 3487 end if; 3488 3489 if Nkind (Selector_Name (N)) = N_Operator_Symbol 3490 and then Scope (Id) /= Standard_Standard 3491 then 3492 -- In addition to user-defined operators in the given scope, 3493 -- there may be an implicit instance of the predefined 3494 -- operator. The operator (defined in Standard) is found 3495 -- in Has_Implicit_Operator, and added to the interpretations. 3496 -- Procedure Add_One_Interp will determine which hides which. 3497 3498 if Has_Implicit_Operator (N) then 3499 null; 3500 end if; 3501 end if; 3502 end Find_Expanded_Name; 3503 3504 ------------------------- 3505 -- Find_Renamed_Entity -- 3506 ------------------------- 3507 3508 function Find_Renamed_Entity 3509 (N : Node_Id; 3510 Nam : Node_Id; 3511 New_S : Entity_Id; 3512 Is_Actual : Boolean := False) return Entity_Id 3513 is 3514 Ind : Interp_Index; 3515 I1 : Interp_Index := 0; -- Suppress junk warnings 3516 It : Interp; 3517 It1 : Interp; 3518 Old_S : Entity_Id; 3519 Inst : Entity_Id; 3520 3521 function Enclosing_Instance return Entity_Id; 3522 -- If the renaming determines the entity for the default of a formal 3523 -- subprogram nested within another instance, choose the innermost 3524 -- candidate. This is because if the formal has a box, and we are within 3525 -- an enclosing instance where some candidate interpretations are local 3526 -- to this enclosing instance, we know that the default was properly 3527 -- resolved when analyzing the generic, so we prefer the local 3528 -- candidates to those that are external. This is not always the case 3529 -- but is a reasonable heuristic on the use of nested generics. 3530 -- The proper solution requires a full renaming model. 3531 3532 function Within (Inner, Outer : Entity_Id) return Boolean; 3533 -- Determine whether a candidate subprogram is defined within 3534 -- the enclosing instance. If yes, it has precedence over outer 3535 -- candidates. 3536 3537 function Is_Visible_Operation (Op : Entity_Id) return Boolean; 3538 -- If the renamed entity is an implicit operator, check whether it is 3539 -- visible because its operand type is properly visible. This 3540 -- check applies to explicit renamed entities that appear in the 3541 -- source in a renaming declaration or a formal subprogram instance, 3542 -- but not to default generic actuals with a name. 3543 3544 ------------------------ 3545 -- Enclosing_Instance -- 3546 ------------------------ 3547 3548 function Enclosing_Instance return Entity_Id is 3549 S : Entity_Id; 3550 3551 begin 3552 if not Is_Generic_Instance (Current_Scope) 3553 and then not Is_Actual 3554 then 3555 return Empty; 3556 end if; 3557 3558 S := Scope (Current_Scope); 3559 3560 while S /= Standard_Standard loop 3561 3562 if Is_Generic_Instance (S) then 3563 return S; 3564 end if; 3565 3566 S := Scope (S); 3567 end loop; 3568 3569 return Empty; 3570 end Enclosing_Instance; 3571 3572 -------------------------- 3573 -- Is_Visible_Operation -- 3574 -------------------------- 3575 3576 function Is_Visible_Operation (Op : Entity_Id) return Boolean is 3577 Scop : Entity_Id; 3578 Typ : Entity_Id; 3579 Btyp : Entity_Id; 3580 3581 begin 3582 if Ekind (Op) /= E_Operator 3583 or else Scope (Op) /= Standard_Standard 3584 or else (In_Instance 3585 and then 3586 (not Is_Actual 3587 or else Present (Enclosing_Instance))) 3588 then 3589 return True; 3590 3591 else 3592 -- For a fixed point type operator, check the resulting type, 3593 -- because it may be a mixed mode integer * fixed operation. 3594 3595 if Present (Next_Formal (First_Formal (New_S))) 3596 and then Is_Fixed_Point_Type (Etype (New_S)) 3597 then 3598 Typ := Etype (New_S); 3599 else 3600 Typ := Etype (First_Formal (New_S)); 3601 end if; 3602 3603 Btyp := Base_Type (Typ); 3604 3605 if Nkind (Nam) /= N_Expanded_Name then 3606 return (In_Open_Scopes (Scope (Btyp)) 3607 or else Is_Potentially_Use_Visible (Btyp) 3608 or else In_Use (Btyp) 3609 or else In_Use (Scope (Btyp))); 3610 3611 else 3612 Scop := Entity (Prefix (Nam)); 3613 3614 if Ekind (Scop) = E_Package 3615 and then Present (Renamed_Object (Scop)) 3616 then 3617 Scop := Renamed_Object (Scop); 3618 end if; 3619 3620 -- Operator is visible if prefix of expanded name denotes 3621 -- scope of type, or else type type is defined in System_Aux 3622 -- and the prefix denotes System. 3623 3624 return Scope (Btyp) = Scop 3625 or else (Scope (Btyp) = System_Aux_Id 3626 and then Scope (Scope (Btyp)) = Scop); 3627 end if; 3628 end if; 3629 end Is_Visible_Operation; 3630 3631 ------------ 3632 -- Within -- 3633 ------------ 3634 3635 function Within (Inner, Outer : Entity_Id) return Boolean is 3636 Sc : Entity_Id := Scope (Inner); 3637 3638 begin 3639 while Sc /= Standard_Standard loop 3640 3641 if Sc = Outer then 3642 return True; 3643 else 3644 Sc := Scope (Sc); 3645 end if; 3646 end loop; 3647 3648 return False; 3649 end Within; 3650 3651 function Report_Overload return Entity_Id; 3652 -- List possible interpretations, and specialize message in the 3653 -- case of a generic actual. 3654 3655 function Report_Overload return Entity_Id is 3656 begin 3657 if Is_Actual then 3658 Error_Msg_NE 3659 ("ambiguous actual subprogram&, " & 3660 "possible interpretations: ", N, Nam); 3661 else 3662 Error_Msg_N 3663 ("ambiguous subprogram, " & 3664 "possible interpretations: ", N); 3665 end if; 3666 3667 List_Interps (Nam, N); 3668 return Old_S; 3669 end Report_Overload; 3670 3671 -- Start of processing for Find_Renamed_Entry 3672 3673 begin 3674 Old_S := Any_Id; 3675 Candidate_Renaming := Empty; 3676 3677 if not Is_Overloaded (Nam) then 3678 if Entity_Matches_Spec (Entity (Nam), New_S) 3679 and then Is_Visible_Operation (Entity (Nam)) 3680 then 3681 Old_S := Entity (Nam); 3682 3683 elsif 3684 Present (First_Formal (Entity (Nam))) 3685 and then Present (First_Formal (New_S)) 3686 and then (Base_Type (Etype (First_Formal (Entity (Nam)))) 3687 = Base_Type (Etype (First_Formal (New_S)))) 3688 then 3689 Candidate_Renaming := Entity (Nam); 3690 end if; 3691 3692 else 3693 Get_First_Interp (Nam, Ind, It); 3694 3695 while Present (It.Nam) loop 3696 3697 if Entity_Matches_Spec (It.Nam, New_S) 3698 and then Is_Visible_Operation (It.Nam) 3699 then 3700 if Old_S /= Any_Id then 3701 3702 -- Note: The call to Disambiguate only happens if a 3703 -- previous interpretation was found, in which case I1 3704 -- has received a value. 3705 3706 It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S)); 3707 3708 if It1 = No_Interp then 3709 3710 Inst := Enclosing_Instance; 3711 3712 if Present (Inst) then 3713 3714 if Within (It.Nam, Inst) then 3715 return (It.Nam); 3716 3717 elsif Within (Old_S, Inst) then 3718 return (Old_S); 3719 3720 else 3721 return Report_Overload; 3722 end if; 3723 3724 else 3725 return Report_Overload; 3726 end if; 3727 3728 else 3729 Old_S := It1.Nam; 3730 exit; 3731 end if; 3732 3733 else 3734 I1 := Ind; 3735 Old_S := It.Nam; 3736 end if; 3737 3738 elsif 3739 Present (First_Formal (It.Nam)) 3740 and then Present (First_Formal (New_S)) 3741 and then (Base_Type (Etype (First_Formal (It.Nam))) 3742 = Base_Type (Etype (First_Formal (New_S)))) 3743 then 3744 Candidate_Renaming := It.Nam; 3745 end if; 3746 3747 Get_Next_Interp (Ind, It); 3748 end loop; 3749 3750 Set_Entity (Nam, Old_S); 3751 Set_Is_Overloaded (Nam, False); 3752 end if; 3753 3754 return Old_S; 3755 end Find_Renamed_Entity; 3756 3757 ----------------------------- 3758 -- Find_Selected_Component -- 3759 ----------------------------- 3760 3761 procedure Find_Selected_Component (N : Node_Id) is 3762 P : constant Node_Id := Prefix (N); 3763 3764 P_Name : Entity_Id; 3765 -- Entity denoted by prefix 3766 3767 P_Type : Entity_Id; 3768 -- and its type 3769 3770 Nam : Node_Id; 3771 3772 begin 3773 Analyze (P); 3774 3775 if Nkind (P) = N_Error then 3776 return; 3777 3778 -- If the selector already has an entity, the node has been 3779 -- constructed in the course of expansion, and is known to be 3780 -- valid. Do not verify that it is defined for the type (it may 3781 -- be a private component used in the expansion of record equality). 3782 3783 elsif Present (Entity (Selector_Name (N))) then 3784 3785 if No (Etype (N)) 3786 or else Etype (N) = Any_Type 3787 then 3788 declare 3789 Sel_Name : constant Node_Id := Selector_Name (N); 3790 Selector : constant Entity_Id := Entity (Sel_Name); 3791 C_Etype : Node_Id; 3792 3793 begin 3794 Set_Etype (Sel_Name, Etype (Selector)); 3795 3796 if not Is_Entity_Name (P) then 3797 Resolve (P); 3798 end if; 3799 3800 -- Build an actual subtype except for the first parameter 3801 -- of an init proc, where this actual subtype is by 3802 -- definition incorrect, since the object is uninitialized 3803 -- (and does not even have defined discriminants etc.) 3804 3805 if Is_Entity_Name (P) 3806 and then Ekind (Entity (P)) = E_Function 3807 then 3808 Nam := New_Copy (P); 3809 3810 if Is_Overloaded (P) then 3811 Save_Interps (P, Nam); 3812 end if; 3813 3814 Rewrite (P, 3815 Make_Function_Call (Sloc (P), Name => Nam)); 3816 Analyze_Call (P); 3817 Analyze_Selected_Component (N); 3818 return; 3819 3820 elsif Ekind (Selector) = E_Component 3821 and then (not Is_Entity_Name (P) 3822 or else Chars (Entity (P)) /= Name_uInit) 3823 then 3824 C_Etype := 3825 Build_Actual_Subtype_Of_Component ( 3826 Etype (Selector), N); 3827 else 3828 C_Etype := Empty; 3829 end if; 3830 3831 if No (C_Etype) then 3832 C_Etype := Etype (Selector); 3833 else 3834 Insert_Action (N, C_Etype); 3835 C_Etype := Defining_Identifier (C_Etype); 3836 end if; 3837 3838 Set_Etype (N, C_Etype); 3839 end; 3840 3841 -- If this is the name of an entry or protected operation, and 3842 -- the prefix is an access type, insert an explicit dereference, 3843 -- so that entry calls are treated uniformly. 3844 3845 if Is_Access_Type (Etype (P)) 3846 and then Is_Concurrent_Type (Designated_Type (Etype (P))) 3847 then 3848 declare 3849 New_P : constant Node_Id := 3850 Make_Explicit_Dereference (Sloc (P), 3851 Prefix => Relocate_Node (P)); 3852 begin 3853 Rewrite (P, New_P); 3854 Set_Etype (P, Designated_Type (Etype (Prefix (P)))); 3855 end; 3856 end if; 3857 3858 -- If the selected component appears within a default expression 3859 -- and it has an actual subtype, the pre-analysis has not yet 3860 -- completed its analysis, because Insert_Actions is disabled in 3861 -- that context. Within the init proc of the enclosing type we 3862 -- must complete this analysis, if an actual subtype was created. 3863 3864 elsif Inside_Init_Proc then 3865 declare 3866 Typ : constant Entity_Id := Etype (N); 3867 Decl : constant Node_Id := Declaration_Node (Typ); 3868 3869 begin 3870 if Nkind (Decl) = N_Subtype_Declaration 3871 and then not Analyzed (Decl) 3872 and then Is_List_Member (Decl) 3873 and then No (Parent (Decl)) 3874 then 3875 Remove (Decl); 3876 Insert_Action (N, Decl); 3877 end if; 3878 end; 3879 end if; 3880 3881 return; 3882 3883 elsif Is_Entity_Name (P) then 3884 P_Name := Entity (P); 3885 3886 -- The prefix may denote an enclosing type which is the completion 3887 -- of an incomplete type declaration. 3888 3889 if Is_Type (P_Name) then 3890 Set_Entity (P, Get_Full_View (P_Name)); 3891 Set_Etype (P, Entity (P)); 3892 P_Name := Entity (P); 3893 end if; 3894 3895 P_Type := Base_Type (Etype (P)); 3896 3897 if Debug_Flag_E then 3898 Write_Str ("Found prefix type to be "); 3899 Write_Entity_Info (P_Type, " "); Write_Eol; 3900 end if; 3901 3902 -- First check for components of a record object (not the 3903 -- result of a call, which is handled below). 3904 3905 if Is_Appropriate_For_Record (P_Type) 3906 and then not Is_Overloadable (P_Name) 3907 and then not Is_Type (P_Name) 3908 then 3909 -- Selected component of record. Type checking will validate 3910 -- name of selector. 3911 3912 Analyze_Selected_Component (N); 3913 3914 elsif Is_Appropriate_For_Entry_Prefix (P_Type) 3915 and then not In_Open_Scopes (P_Name) 3916 and then (not Is_Concurrent_Type (Etype (P_Name)) 3917 or else not In_Open_Scopes (Etype (P_Name))) 3918 then 3919 -- Call to protected operation or entry. Type checking is 3920 -- needed on the prefix. 3921 3922 Analyze_Selected_Component (N); 3923 3924 elsif (In_Open_Scopes (P_Name) 3925 and then Ekind (P_Name) /= E_Void 3926 and then not Is_Overloadable (P_Name)) 3927 or else (Is_Concurrent_Type (Etype (P_Name)) 3928 and then In_Open_Scopes (Etype (P_Name))) 3929 then 3930 -- Prefix denotes an enclosing loop, block, or task, i.e. an 3931 -- enclosing construct that is not a subprogram or accept. 3932 3933 Find_Expanded_Name (N); 3934 3935 elsif Ekind (P_Name) = E_Package then 3936 Find_Expanded_Name (N); 3937 3938 elsif Is_Overloadable (P_Name) then 3939 3940 -- The subprogram may be a renaming (of an enclosing scope) as 3941 -- in the case of the name of the generic within an instantiation. 3942 3943 if (Ekind (P_Name) = E_Procedure 3944 or else Ekind (P_Name) = E_Function) 3945 and then Present (Alias (P_Name)) 3946 and then Is_Generic_Instance (Alias (P_Name)) 3947 then 3948 P_Name := Alias (P_Name); 3949 end if; 3950 3951 if Is_Overloaded (P) then 3952 3953 -- The prefix must resolve to a unique enclosing construct. 3954 3955 declare 3956 Found : Boolean := False; 3957 Ind : Interp_Index; 3958 It : Interp; 3959 3960 begin 3961 Get_First_Interp (P, Ind, It); 3962 3963 while Present (It.Nam) loop 3964 3965 if In_Open_Scopes (It.Nam) then 3966 if Found then 3967 Error_Msg_N ( 3968 "prefix must be unique enclosing scope", N); 3969 Set_Entity (N, Any_Id); 3970 Set_Etype (N, Any_Type); 3971 return; 3972 3973 else 3974 Found := True; 3975 P_Name := It.Nam; 3976 end if; 3977 end if; 3978 3979 Get_Next_Interp (Ind, It); 3980 end loop; 3981 end; 3982 end if; 3983 3984 if In_Open_Scopes (P_Name) then 3985 Set_Entity (P, P_Name); 3986 Set_Is_Overloaded (P, False); 3987 Find_Expanded_Name (N); 3988 3989 else 3990 -- If no interpretation as an expanded name is possible, it 3991 -- must be a selected component of a record returned by a 3992 -- function call. Reformat prefix as a function call, the 3993 -- rest is done by type resolution. If the prefix is a 3994 -- procedure or entry, as is P.X; this is an error. 3995 3996 if Ekind (P_Name) /= E_Function 3997 and then (not Is_Overloaded (P) 3998 or else 3999 Nkind (Parent (N)) = N_Procedure_Call_Statement) 4000 then 4001 4002 -- Prefix may mention a package that is hidden by a local 4003 -- declaration: let the user know. Scan the full homonym 4004 -- chain, the candidate package may be anywhere on it. 4005 4006 if Present (Homonym (Current_Entity (P_Name))) then 4007 4008 P_Name := Current_Entity (P_Name); 4009 4010 while Present (P_Name) loop 4011 exit when Ekind (P_Name) = E_Package; 4012 P_Name := Homonym (P_Name); 4013 end loop; 4014 4015 if Present (P_Name) then 4016 Error_Msg_Sloc := Sloc (Entity (Prefix (N))); 4017 4018 Error_Msg_NE 4019 ("package& is hidden by declaration#", 4020 N, P_Name); 4021 4022 Set_Entity (Prefix (N), P_Name); 4023 Find_Expanded_Name (N); 4024 return; 4025 else 4026 P_Name := Entity (Prefix (N)); 4027 end if; 4028 end if; 4029 4030 Error_Msg_NE 4031 ("invalid prefix in selected component&", N, P_Name); 4032 Change_Selected_Component_To_Expanded_Name (N); 4033 Set_Entity (N, Any_Id); 4034 Set_Etype (N, Any_Type); 4035 4036 else 4037 Nam := New_Copy (P); 4038 Save_Interps (P, Nam); 4039 Rewrite (P, 4040 Make_Function_Call (Sloc (P), Name => Nam)); 4041 Analyze_Call (P); 4042 Analyze_Selected_Component (N); 4043 end if; 4044 end if; 4045 4046 -- Remaining cases generate various error messages 4047 4048 else 4049 -- Format node as expanded name, to avoid cascaded errors 4050 4051 Change_Selected_Component_To_Expanded_Name (N); 4052 Set_Entity (N, Any_Id); 4053 Set_Etype (N, Any_Type); 4054 4055 -- Issue error message, but avoid this if error issued already. 4056 -- Use identifier of prefix if one is available. 4057 4058 if P_Name = Any_Id then 4059 null; 4060 4061 elsif Ekind (P_Name) = E_Void then 4062 Premature_Usage (P); 4063 4064 elsif Nkind (P) /= N_Attribute_Reference then 4065 Error_Msg_N ( 4066 "invalid prefix in selected component&", P); 4067 4068 if Is_Access_Type (P_Type) 4069 and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type 4070 then 4071 Error_Msg_N 4072 ("\dereference must not be of an incomplete type " & 4073 "('R'M 3.10.1)", P); 4074 end if; 4075 4076 else 4077 Error_Msg_N ( 4078 "invalid prefix in selected component", P); 4079 end if; 4080 end if; 4081 4082 else 4083 -- If prefix is not the name of an entity, it must be an expression, 4084 -- whose type is appropriate for a record. This is determined by 4085 -- type resolution. 4086 4087 Analyze_Selected_Component (N); 4088 end if; 4089 end Find_Selected_Component; 4090 4091 --------------- 4092 -- Find_Type -- 4093 --------------- 4094 4095 procedure Find_Type (N : Node_Id) is 4096 C : Entity_Id; 4097 Typ : Entity_Id; 4098 T : Entity_Id; 4099 T_Name : Entity_Id; 4100 4101 begin 4102 if N = Error then 4103 return; 4104 4105 elsif Nkind (N) = N_Attribute_Reference then 4106 4107 -- Class attribute. This is only valid in Ada 95 mode, but we don't 4108 -- do a check, since the tagged type referenced could only exist if 4109 -- we were in 95 mode when it was declared (or, if we were in Ada 4110 -- 83 mode, then an error message would already have been issued). 4111 4112 if Attribute_Name (N) = Name_Class then 4113 Check_Restriction (No_Dispatch, N); 4114 Find_Type (Prefix (N)); 4115 4116 -- Propagate error from bad prefix 4117 4118 if Etype (Prefix (N)) = Any_Type then 4119 Set_Entity (N, Any_Type); 4120 Set_Etype (N, Any_Type); 4121 return; 4122 end if; 4123 4124 T := Base_Type (Entity (Prefix (N))); 4125 4126 -- Case of non-tagged type 4127 4128 if not Is_Tagged_Type (T) then 4129 if Ekind (T) = E_Incomplete_Type then 4130 4131 -- It is legal to denote the class type of an incomplete 4132 -- type. The full type will have to be tagged, of course. 4133 4134 Set_Is_Tagged_Type (T); 4135 Make_Class_Wide_Type (T); 4136 Set_Entity (N, Class_Wide_Type (T)); 4137 Set_Etype (N, Class_Wide_Type (T)); 4138 4139 elsif Ekind (T) = E_Private_Type 4140 and then not Is_Generic_Type (T) 4141 and then In_Private_Part (Scope (T)) 4142 then 4143 -- The Class attribute can be applied to an untagged 4144 -- private type fulfilled by a tagged type prior to 4145 -- the full type declaration (but only within the 4146 -- parent package's private part). Create the class-wide 4147 -- type now and check that the full type is tagged 4148 -- later during its analysis. Note that we do not 4149 -- mark the private type as tagged, unlike the case 4150 -- of incomplete types, because the type must still 4151 -- appear untagged to outside units. 4152 4153 if not Present (Class_Wide_Type (T)) then 4154 Make_Class_Wide_Type (T); 4155 end if; 4156 4157 Set_Entity (N, Class_Wide_Type (T)); 4158 Set_Etype (N, Class_Wide_Type (T)); 4159 4160 else 4161 -- Should we introduce a type Any_Tagged and use 4162 -- Wrong_Type here, it would be a bit more consistent??? 4163 4164 Error_Msg_NE 4165 ("tagged type required, found}", 4166 Prefix (N), First_Subtype (T)); 4167 Set_Entity (N, Any_Type); 4168 return; 4169 end if; 4170 4171 -- Case of tagged type 4172 4173 else 4174 C := Class_Wide_Type (Entity (Prefix (N))); 4175 Set_Entity_With_Style_Check (N, C); 4176 Generate_Reference (C, N); 4177 Set_Etype (N, C); 4178 end if; 4179 4180 -- Base attribute, allowed in Ada 95 mode only 4181 4182 elsif Attribute_Name (N) = Name_Base then 4183 if Ada_83 and then Comes_From_Source (N) then 4184 Error_Msg_N 4185 ("(Ada 83) Base attribute not allowed in subtype mark", N); 4186 4187 else 4188 Find_Type (Prefix (N)); 4189 Typ := Entity (Prefix (N)); 4190 4191 if Ada_95 4192 and then not Is_Scalar_Type (Typ) 4193 and then not Is_Generic_Type (Typ) 4194 then 4195 Error_Msg_N 4196 ("prefix of Base attribute must be scalar type", Typ); 4197 4198 elsif Sloc (Typ) = Standard_Location 4199 and then Base_Type (Typ) = Typ 4200 and then Warn_On_Redundant_Constructs 4201 then 4202 Error_Msg_NE 4203 ("?redudant attribute, & is its own base type", N, Typ); 4204 end if; 4205 4206 T := Base_Type (Typ); 4207 4208 -- Rewrite attribute reference with type itself (see similar 4209 -- processing in Analyze_Attribute, case Base). Preserve 4210 -- prefix if present, for other legality checks. 4211 4212 if Nkind (Prefix (N)) = N_Expanded_Name then 4213 Rewrite (N, 4214 Make_Expanded_Name (Sloc (N), 4215 Chars => Chars (Entity (N)), 4216 Prefix => New_Copy (Prefix (Prefix (N))), 4217 Selector_Name => 4218 New_Reference_To (Entity (N), Sloc (N)))); 4219 4220 else 4221 Rewrite (N, 4222 New_Reference_To (Entity (N), Sloc (N))); 4223 end if; 4224 4225 Set_Entity (N, T); 4226 Set_Etype (N, T); 4227 end if; 4228 4229 -- All other attributes are invalid in a subtype mark 4230 4231 else 4232 Error_Msg_N ("invalid attribute in subtype mark", N); 4233 end if; 4234 4235 else 4236 Analyze (N); 4237 4238 if Is_Entity_Name (N) then 4239 T_Name := Entity (N); 4240 else 4241 Error_Msg_N ("subtype mark required in this context", N); 4242 Set_Etype (N, Any_Type); 4243 return; 4244 end if; 4245 4246 if T_Name = Any_Id or else Etype (N) = Any_Type then 4247 4248 -- Undefined id. Make it into a valid type 4249 4250 Set_Entity (N, Any_Type); 4251 4252 elsif not Is_Type (T_Name) 4253 and then T_Name /= Standard_Void_Type 4254 then 4255 Error_Msg_Sloc := Sloc (T_Name); 4256 Error_Msg_N ("subtype mark required in this context", N); 4257 Error_Msg_NE ("\found & declared#", N, T_Name); 4258 Set_Entity (N, Any_Type); 4259 4260 else 4261 T_Name := Get_Full_View (T_Name); 4262 4263 if In_Open_Scopes (T_Name) then 4264 if Ekind (Base_Type (T_Name)) = E_Task_Type then 4265 Error_Msg_N ("task type cannot be used as type mark " & 4266 "within its own body", N); 4267 else 4268 Error_Msg_N ("type declaration cannot refer to itself", N); 4269 end if; 4270 4271 Set_Etype (N, Any_Type); 4272 Set_Entity (N, Any_Type); 4273 Set_Error_Posted (T_Name); 4274 return; 4275 end if; 4276 4277 Set_Entity (N, T_Name); 4278 Set_Etype (N, T_Name); 4279 end if; 4280 end if; 4281 4282 if Present (Etype (N)) and then Comes_From_Source (N) then 4283 if Is_Fixed_Point_Type (Etype (N)) then 4284 Check_Restriction (No_Fixed_Point, N); 4285 elsif Is_Floating_Point_Type (Etype (N)) then 4286 Check_Restriction (No_Floating_Point, N); 4287 end if; 4288 end if; 4289 end Find_Type; 4290 4291 ------------------- 4292 -- Get_Full_View -- 4293 ------------------- 4294 4295 function Get_Full_View (T_Name : Entity_Id) return Entity_Id is 4296 begin 4297 if Ekind (T_Name) = E_Incomplete_Type 4298 and then Present (Full_View (T_Name)) 4299 then 4300 return Full_View (T_Name); 4301 4302 elsif Is_Class_Wide_Type (T_Name) 4303 and then Ekind (Root_Type (T_Name)) = E_Incomplete_Type 4304 and then Present (Full_View (Root_Type (T_Name))) 4305 then 4306 return Class_Wide_Type (Full_View (Root_Type (T_Name))); 4307 4308 else 4309 return T_Name; 4310 end if; 4311 end Get_Full_View; 4312 4313 ------------------------------------ 4314 -- Has_Implicit_Character_Literal -- 4315 ------------------------------------ 4316 4317 function Has_Implicit_Character_Literal (N : Node_Id) return Boolean is 4318 Id : Entity_Id; 4319 Found : Boolean := False; 4320 P : constant Entity_Id := Entity (Prefix (N)); 4321 Priv_Id : Entity_Id := Empty; 4322 4323 begin 4324 if Ekind (P) = E_Package 4325 and then not In_Open_Scopes (P) 4326 then 4327 Priv_Id := First_Private_Entity (P); 4328 end if; 4329 4330 if P = Standard_Standard then 4331 Change_Selected_Component_To_Expanded_Name (N); 4332 Rewrite (N, Selector_Name (N)); 4333 Analyze (N); 4334 Set_Etype (Original_Node (N), Standard_Character); 4335 return True; 4336 end if; 4337 4338 Id := First_Entity (P); 4339 4340 while Present (Id) 4341 and then Id /= Priv_Id 4342 loop 4343 if Is_Character_Type (Id) 4344 and then (Root_Type (Id) = Standard_Character 4345 or else Root_Type (Id) = Standard_Wide_Character) 4346 and then Id = Base_Type (Id) 4347 then 4348 -- We replace the node with the literal itself, resolve as a 4349 -- character, and set the type correctly. 4350 4351 if not Found then 4352 Change_Selected_Component_To_Expanded_Name (N); 4353 Rewrite (N, Selector_Name (N)); 4354 Analyze (N); 4355 Set_Etype (N, Id); 4356 Set_Etype (Original_Node (N), Id); 4357 Found := True; 4358 4359 else 4360 -- More than one type derived from Character in given scope. 4361 -- Collect all possible interpretations. 4362 4363 Add_One_Interp (N, Id, Id); 4364 end if; 4365 end if; 4366 4367 Next_Entity (Id); 4368 end loop; 4369 4370 return Found; 4371 end Has_Implicit_Character_Literal; 4372 4373 --------------------------- 4374 -- Has_Implicit_Operator -- 4375 --------------------------- 4376 4377 function Has_Implicit_Operator (N : Node_Id) return Boolean is 4378 Op_Id : constant Name_Id := Chars (Selector_Name (N)); 4379 P : constant Entity_Id := Entity (Prefix (N)); 4380 Id : Entity_Id; 4381 Priv_Id : Entity_Id := Empty; 4382 4383 procedure Add_Implicit_Operator 4384 (T : Entity_Id; 4385 Op_Type : Entity_Id := Empty); 4386 -- Add implicit interpretation to node N, using the type for which 4387 -- a predefined operator exists. If the operator yields a boolean 4388 -- type, the Operand_Type is implicitly referenced by the operator, 4389 -- and a reference to it must be generated. 4390 4391 --------------------------- 4392 -- Add_Implicit_Operator -- 4393 --------------------------- 4394 4395 procedure Add_Implicit_Operator 4396 (T : Entity_Id; 4397 Op_Type : Entity_Id := Empty) 4398 is 4399 Predef_Op : Entity_Id; 4400 4401 begin 4402 Predef_Op := Current_Entity (Selector_Name (N)); 4403 4404 while Present (Predef_Op) 4405 and then Scope (Predef_Op) /= Standard_Standard 4406 loop 4407 Predef_Op := Homonym (Predef_Op); 4408 end loop; 4409 4410 if Nkind (N) = N_Selected_Component then 4411 Change_Selected_Component_To_Expanded_Name (N); 4412 end if; 4413 4414 Add_One_Interp (N, Predef_Op, T); 4415 4416 -- For operators with unary and binary interpretations, add both 4417 4418 if Present (Homonym (Predef_Op)) then 4419 Add_One_Interp (N, Homonym (Predef_Op), T); 4420 end if; 4421 4422 -- The node is a reference to a predefined operator, and 4423 -- an implicit reference to the type of its operands. 4424 4425 if Present (Op_Type) then 4426 Generate_Operator_Reference (N, Op_Type); 4427 else 4428 Generate_Operator_Reference (N, T); 4429 end if; 4430 end Add_Implicit_Operator; 4431 4432 -- Start of processing for Has_Implicit_Operator 4433 4434 begin 4435 4436 if Ekind (P) = E_Package 4437 and then not In_Open_Scopes (P) 4438 then 4439 Priv_Id := First_Private_Entity (P); 4440 end if; 4441 4442 Id := First_Entity (P); 4443 4444 case Op_Id is 4445 4446 -- Boolean operators: an implicit declaration exists if the scope 4447 -- contains a declaration for a derived Boolean type, or for an 4448 -- array of Boolean type. 4449 4450 when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => 4451 4452 while Id /= Priv_Id loop 4453 4454 if Valid_Boolean_Arg (Id) 4455 and then Id = Base_Type (Id) 4456 then 4457 Add_Implicit_Operator (Id); 4458 return True; 4459 end if; 4460 4461 Next_Entity (Id); 4462 end loop; 4463 4464 -- Equality: look for any non-limited type. Result is Boolean. 4465 4466 when Name_Op_Eq | Name_Op_Ne => 4467 4468 while Id /= Priv_Id loop 4469 4470 if Is_Type (Id) 4471 and then not Is_Limited_Type (Id) 4472 and then Id = Base_Type (Id) 4473 then 4474 Add_Implicit_Operator (Standard_Boolean, Id); 4475 return True; 4476 end if; 4477 4478 Next_Entity (Id); 4479 end loop; 4480 4481 -- Comparison operators: scalar type, or array of scalar. 4482 4483 when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => 4484 4485 while Id /= Priv_Id loop 4486 if (Is_Scalar_Type (Id) 4487 or else (Is_Array_Type (Id) 4488 and then Is_Scalar_Type (Component_Type (Id)))) 4489 and then Id = Base_Type (Id) 4490 then 4491 Add_Implicit_Operator (Standard_Boolean, Id); 4492 return True; 4493 end if; 4494 4495 Next_Entity (Id); 4496 end loop; 4497 4498 -- Arithmetic operators: any numeric type 4499 4500 when Name_Op_Abs | 4501 Name_Op_Add | 4502 Name_Op_Mod | 4503 Name_Op_Rem | 4504 Name_Op_Subtract | 4505 Name_Op_Multiply | 4506 Name_Op_Divide | 4507 Name_Op_Expon => 4508 4509 while Id /= Priv_Id loop 4510 if Is_Numeric_Type (Id) 4511 and then Id = Base_Type (Id) 4512 then 4513 Add_Implicit_Operator (Id); 4514 return True; 4515 end if; 4516 4517 Next_Entity (Id); 4518 end loop; 4519 4520 -- Concatenation: any one-dimensional array type 4521 4522 when Name_Op_Concat => 4523 4524 while Id /= Priv_Id loop 4525 if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1 4526 and then Id = Base_Type (Id) 4527 then 4528 Add_Implicit_Operator (Id); 4529 return True; 4530 end if; 4531 4532 Next_Entity (Id); 4533 end loop; 4534 4535 -- What is the others condition here? Should we be using a 4536 -- subtype of Name_Id that would restrict to operators ??? 4537 4538 when others => null; 4539 4540 end case; 4541 4542 -- If we fall through, then we do not have an implicit operator 4543 4544 return False; 4545 4546 end Has_Implicit_Operator; 4547 4548 -------------------- 4549 -- In_Open_Scopes -- 4550 -------------------- 4551 4552 function In_Open_Scopes (S : Entity_Id) return Boolean is 4553 begin 4554 -- Since there are several scope stacks maintained by Scope_Stack each 4555 -- delineated by Standard (see comments by definition of Scope_Stack) 4556 -- it is necessary to end the search when Standard is reached. 4557 4558 for J in reverse 0 .. Scope_Stack.Last loop 4559 if Scope_Stack.Table (J).Entity = S then 4560 return True; 4561 end if; 4562 4563 -- We need Is_Active_Stack_Base to tell us when to stop rather 4564 -- than checking for Standard_Standard because there are cases 4565 -- where Standard_Standard appears in the middle of the active 4566 -- set of scopes. This affects the declaration and overriding 4567 -- of private inherited operations in instantiations of generic 4568 -- child units. 4569 4570 exit when Scope_Stack.Table (J).Is_Active_Stack_Base; 4571 end loop; 4572 4573 return False; 4574 end In_Open_Scopes; 4575 4576 ----------------------------- 4577 -- Inherit_Renamed_Profile -- 4578 ----------------------------- 4579 4580 procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id) is 4581 New_F : Entity_Id; 4582 Old_F : Entity_Id; 4583 Old_T : Entity_Id; 4584 New_T : Entity_Id; 4585 4586 begin 4587 if Ekind (Old_S) = E_Operator then 4588 4589 New_F := First_Formal (New_S); 4590 4591 while Present (New_F) loop 4592 Set_Etype (New_F, Base_Type (Etype (New_F))); 4593 Next_Formal (New_F); 4594 end loop; 4595 4596 Set_Etype (New_S, Base_Type (Etype (New_S))); 4597 4598 else 4599 New_F := First_Formal (New_S); 4600 Old_F := First_Formal (Old_S); 4601 4602 while Present (New_F) loop 4603 New_T := Etype (New_F); 4604 Old_T := Etype (Old_F); 4605 4606 -- If the new type is a renaming of the old one, as is the 4607 -- case for actuals in instances, retain its name, to simplify 4608 -- later disambiguation. 4609 4610 if Nkind (Parent (New_T)) = N_Subtype_Declaration 4611 and then Is_Entity_Name (Subtype_Indication (Parent (New_T))) 4612 and then Entity (Subtype_Indication (Parent (New_T))) = Old_T 4613 then 4614 null; 4615 else 4616 Set_Etype (New_F, Old_T); 4617 end if; 4618 4619 Next_Formal (New_F); 4620 Next_Formal (Old_F); 4621 end loop; 4622 4623 if Ekind (Old_S) = E_Function 4624 or else Ekind (Old_S) = E_Enumeration_Literal 4625 then 4626 Set_Etype (New_S, Etype (Old_S)); 4627 end if; 4628 end if; 4629 end Inherit_Renamed_Profile; 4630 4631 ---------------- 4632 -- Initialize -- 4633 ---------------- 4634 4635 procedure Initialize is 4636 begin 4637 Urefs.Init; 4638 end Initialize; 4639 4640 ------------------------- 4641 -- Install_Use_Clauses -- 4642 ------------------------- 4643 4644 procedure Install_Use_Clauses (Clause : Node_Id) is 4645 U : Node_Id := Clause; 4646 P : Node_Id; 4647 Id : Entity_Id; 4648 4649 begin 4650 while Present (U) loop 4651 4652 -- Case of USE package 4653 4654 if Nkind (U) = N_Use_Package_Clause then 4655 P := First (Names (U)); 4656 4657 while Present (P) loop 4658 Id := Entity (P); 4659 4660 if Ekind (Id) = E_Package then 4661 4662 if In_Use (Id) then 4663 Set_Redundant_Use (P, True); 4664 4665 elsif Present (Renamed_Object (Id)) 4666 and then In_Use (Renamed_Object (Id)) 4667 then 4668 Set_Redundant_Use (P, True); 4669 4670 else 4671 Use_One_Package (Id, U); 4672 end if; 4673 end if; 4674 4675 Next (P); 4676 end loop; 4677 4678 -- case of USE TYPE 4679 4680 else 4681 P := First (Subtype_Marks (U)); 4682 4683 while Present (P) loop 4684 if not Is_Entity_Name (P) 4685 or else No (Entity (P)) 4686 then 4687 null; 4688 4689 elsif Entity (P) /= Any_Type then 4690 Use_One_Type (P); 4691 end if; 4692 4693 Next (P); 4694 end loop; 4695 end if; 4696 4697 Next_Use_Clause (U); 4698 end loop; 4699 end Install_Use_Clauses; 4700 4701 ------------------------------------- 4702 -- Is_Appropriate_For_Entry_Prefix -- 4703 ------------------------------------- 4704 4705 function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is 4706 P_Type : Entity_Id := T; 4707 4708 begin 4709 if Is_Access_Type (P_Type) then 4710 P_Type := Designated_Type (P_Type); 4711 end if; 4712 4713 return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); 4714 end Is_Appropriate_For_Entry_Prefix; 4715 4716 ------------------------------- 4717 -- Is_Appropriate_For_Record -- 4718 ------------------------------- 4719 4720 function Is_Appropriate_For_Record 4721 (T : Entity_Id) 4722 return Boolean 4723 is 4724 function Has_Components (T1 : Entity_Id) return Boolean; 4725 -- Determine if given type has components (i.e. is either a record 4726 -- type or a type that has discriminants). 4727 4728 function Has_Components (T1 : Entity_Id) return Boolean is 4729 begin 4730 return Is_Record_Type (T1) 4731 or else (Is_Private_Type (T1) and then Has_Discriminants (T1)) 4732 or else (Is_Task_Type (T1) and then Has_Discriminants (T1)); 4733 end Has_Components; 4734 4735 -- Start of processing for Is_Appropriate_For_Record 4736 4737 begin 4738 return 4739 Present (T) 4740 and then (Has_Components (T) 4741 or else (Is_Access_Type (T) 4742 and then 4743 Has_Components (Designated_Type (T)))); 4744 end Is_Appropriate_For_Record; 4745 4746 --------------- 4747 -- New_Scope -- 4748 --------------- 4749 4750 procedure New_Scope (S : Entity_Id) is 4751 E : Entity_Id; 4752 4753 begin 4754 if Ekind (S) = E_Void then 4755 null; 4756 4757 -- Set scope depth if not a non-concurrent type, and we have not 4758 -- yet set the scope depth. This means that we have the first 4759 -- occurrence of the scope, and this is where the depth is set. 4760 4761 elsif (not Is_Type (S) or else Is_Concurrent_Type (S)) 4762 and then not Scope_Depth_Set (S) 4763 then 4764 if S = Standard_Standard then 4765 Set_Scope_Depth_Value (S, Uint_0); 4766 4767 elsif Is_Child_Unit (S) then 4768 Set_Scope_Depth_Value (S, Uint_1); 4769 4770 elsif not Is_Record_Type (Current_Scope) then 4771 if Ekind (S) = E_Loop then 4772 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope)); 4773 else 4774 Set_Scope_Depth_Value (S, Scope_Depth (Current_Scope) + 1); 4775 end if; 4776 end if; 4777 end if; 4778 4779 Scope_Stack.Increment_Last; 4780 4781 declare 4782 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 4783 4784 begin 4785 SST.Entity := S; 4786 SST.Save_Scope_Suppress := Scope_Suppress; 4787 SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last; 4788 4789 if Scope_Stack.Last > Scope_Stack.First then 4790 SST.Component_Alignment_Default := Scope_Stack.Table 4791 (Scope_Stack.Last - 1). 4792 Component_Alignment_Default; 4793 end if; 4794 4795 SST.Last_Subprogram_Name := null; 4796 SST.Is_Transient := False; 4797 SST.Node_To_Be_Wrapped := Empty; 4798 SST.Pending_Freeze_Actions := No_List; 4799 SST.Actions_To_Be_Wrapped_Before := No_List; 4800 SST.Actions_To_Be_Wrapped_After := No_List; 4801 SST.First_Use_Clause := Empty; 4802 SST.Is_Active_Stack_Base := False; 4803 end; 4804 4805 if Debug_Flag_W then 4806 Write_Str ("--> new scope: "); 4807 Write_Name (Chars (Current_Scope)); 4808 Write_Str (", Id="); 4809 Write_Int (Int (Current_Scope)); 4810 Write_Str (", Depth="); 4811 Write_Int (Int (Scope_Stack.Last)); 4812 Write_Eol; 4813 end if; 4814 4815 -- Copy from Scope (S) the categorization flags to S, this is not 4816 -- done in case Scope (S) is Standard_Standard since propagation 4817 -- is from library unit entity inwards. 4818 4819 if S /= Standard_Standard 4820 and then Scope (S) /= Standard_Standard 4821 and then not Is_Child_Unit (S) 4822 then 4823 E := Scope (S); 4824 4825 if Nkind (E) not in N_Entity then 4826 return; 4827 end if; 4828 4829 -- We only propagate inwards for library level entities, 4830 -- inner level subprograms do not inherit the categorization. 4831 4832 if Is_Library_Level_Entity (S) then 4833 Set_Is_Preelaborated (S, Is_Preelaborated (E)); 4834 Set_Is_Shared_Passive (S, Is_Shared_Passive (E)); 4835 Set_Categorization_From_Scope (E => S, Scop => E); 4836 end if; 4837 end if; 4838 end New_Scope; 4839 4840 --------------- 4841 -- Pop_Scope -- 4842 --------------- 4843 4844 procedure Pop_Scope is 4845 SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last); 4846 4847 begin 4848 if Debug_Flag_E then 4849 Write_Info; 4850 end if; 4851 4852 Scope_Suppress := SST.Save_Scope_Suppress; 4853 Local_Entity_Suppress.Set_Last (SST.Save_Local_Entity_Suppress); 4854 4855 if Debug_Flag_W then 4856 Write_Str ("--> exiting scope: "); 4857 Write_Name (Chars (Current_Scope)); 4858 Write_Str (", Depth="); 4859 Write_Int (Int (Scope_Stack.Last)); 4860 Write_Eol; 4861 end if; 4862 4863 End_Use_Clauses (SST.First_Use_Clause); 4864 4865 -- If the actions to be wrapped are still there they will get lost 4866 -- causing incomplete code to be generated. It is better to abort in 4867 -- this case (and we do the abort even with assertions off since the 4868 -- penalty is incorrect code generation) 4869 4870 if SST.Actions_To_Be_Wrapped_Before /= No_List 4871 or else 4872 SST.Actions_To_Be_Wrapped_After /= No_List 4873 then 4874 return; 4875 end if; 4876 4877 -- Free last subprogram name if allocated, and pop scope 4878 4879 Free (SST.Last_Subprogram_Name); 4880 Scope_Stack.Decrement_Last; 4881 end Pop_Scope; 4882 4883 --------------------- 4884 -- Premature_Usage -- 4885 --------------------- 4886 4887 procedure Premature_Usage (N : Node_Id) is 4888 Kind : constant Node_Kind := Nkind (Parent (Entity (N))); 4889 E : Entity_Id := Entity (N); 4890 4891 begin 4892 -- Within an instance, the analysis of the actual for a formal object 4893 -- does not see the name of the object itself. This is significant 4894 -- only if the object is an aggregate, where its analysis does not do 4895 -- any name resolution on component associations. (see 4717-008). In 4896 -- such a case, look for the visible homonym on the chain. 4897 4898 if In_Instance 4899 and then Present (Homonym (E)) 4900 then 4901 E := Homonym (E); 4902 4903 while Present (E) 4904 and then not In_Open_Scopes (Scope (E)) 4905 loop 4906 E := Homonym (E); 4907 end loop; 4908 4909 if Present (E) then 4910 Set_Entity (N, E); 4911 Set_Etype (N, Etype (E)); 4912 return; 4913 end if; 4914 end if; 4915 4916 if Kind = N_Component_Declaration then 4917 Error_Msg_N 4918 ("component&! cannot be used before end of record declaration", N); 4919 4920 elsif Kind = N_Parameter_Specification then 4921 Error_Msg_N 4922 ("formal parameter&! cannot be used before end of specification", 4923 N); 4924 4925 elsif Kind = N_Discriminant_Specification then 4926 Error_Msg_N 4927 ("discriminant&! cannot be used before end of discriminant part", 4928 N); 4929 4930 elsif Kind = N_Procedure_Specification 4931 or else Kind = N_Function_Specification 4932 then 4933 Error_Msg_N 4934 ("subprogram&! cannot be used before end of its declaration", 4935 N); 4936 else 4937 Error_Msg_N 4938 ("object& cannot be used before end of its declaration!", N); 4939 end if; 4940 end Premature_Usage; 4941 4942 ------------------------ 4943 -- Present_System_Aux -- 4944 ------------------------ 4945 4946 function Present_System_Aux (N : Node_Id := Empty) return Boolean is 4947 Loc : Source_Ptr; 4948 Aux_Name : Name_Id; 4949 Unum : Unit_Number_Type; 4950 Withn : Node_Id; 4951 With_Sys : Node_Id; 4952 The_Unit : Node_Id; 4953 4954 function Find_System (C_Unit : Node_Id) return Entity_Id; 4955 -- Scan context clause of compilation unit to find a with_clause 4956 -- for System. 4957 4958 function Find_System (C_Unit : Node_Id) return Entity_Id is 4959 With_Clause : Node_Id; 4960 4961 begin 4962 With_Clause := First (Context_Items (C_Unit)); 4963 4964 while Present (With_Clause) loop 4965 if (Nkind (With_Clause) = N_With_Clause 4966 and then Chars (Name (With_Clause)) = Name_System) 4967 and then Comes_From_Source (With_Clause) 4968 then 4969 return With_Clause; 4970 end if; 4971 4972 Next (With_Clause); 4973 end loop; 4974 4975 return Empty; 4976 end Find_System; 4977 4978 -- Start of processing for Present_System_Aux 4979 4980 begin 4981 -- The child unit may have been loaded and analyzed already. 4982 4983 if Present (System_Aux_Id) then 4984 return True; 4985 4986 -- If no previous pragma for System.Aux, nothing to load 4987 4988 elsif No (System_Extend_Unit) then 4989 return False; 4990 4991 -- Use the unit name given in the pragma to retrieve the unit. 4992 -- Verify that System itself appears in the context clause of the 4993 -- current compilation. If System is not present, an error will 4994 -- have been reported already. 4995 4996 else 4997 With_Sys := Find_System (Cunit (Current_Sem_Unit)); 4998 4999 The_Unit := Unit (Cunit (Current_Sem_Unit)); 5000 5001 if No (With_Sys) 5002 and then (Nkind (The_Unit) = N_Package_Body 5003 or else (Nkind (The_Unit) = N_Subprogram_Body 5004 and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) 5005 then 5006 With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit))); 5007 end if; 5008 5009 if No (With_Sys) 5010 and then Present (N) 5011 then 5012 -- If we are compiling a subunit, we need to examine its 5013 -- context as well (Current_Sem_Unit is the parent unit); 5014 5015 The_Unit := Parent (N); 5016 5017 while Nkind (The_Unit) /= N_Compilation_Unit loop 5018 The_Unit := Parent (The_Unit); 5019 end loop; 5020 5021 if Nkind (Unit (The_Unit)) = N_Subunit then 5022 With_Sys := Find_System (The_Unit); 5023 end if; 5024 end if; 5025 5026 if No (With_Sys) then 5027 return False; 5028 end if; 5029 5030 Loc := Sloc (With_Sys); 5031 Get_Name_String (Chars (Expression (System_Extend_Unit))); 5032 Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len); 5033 Name_Buffer (1 .. 7) := "system."; 5034 Name_Buffer (Name_Len + 8) := '%'; 5035 Name_Buffer (Name_Len + 9) := 's'; 5036 Name_Len := Name_Len + 9; 5037 Aux_Name := Name_Find; 5038 5039 Unum := 5040 Load_Unit 5041 (Load_Name => Aux_Name, 5042 Required => False, 5043 Subunit => False, 5044 Error_Node => With_Sys); 5045 5046 if Unum /= No_Unit then 5047 Semantics (Cunit (Unum)); 5048 System_Aux_Id := 5049 Defining_Entity (Specification (Unit (Cunit (Unum)))); 5050 5051 Withn := Make_With_Clause (Loc, 5052 Name => 5053 Make_Expanded_Name (Loc, 5054 Chars => Chars (System_Aux_Id), 5055 Prefix => 5056 New_Reference_To (Scope (System_Aux_Id), Loc), 5057 Selector_Name => 5058 New_Reference_To (System_Aux_Id, Loc))); 5059 5060 Set_Entity (Name (Withn), System_Aux_Id); 5061 5062 Set_Library_Unit (Withn, Cunit (Unum)); 5063 Set_Corresponding_Spec (Withn, System_Aux_Id); 5064 Set_First_Name (Withn, True); 5065 Set_Implicit_With (Withn, True); 5066 5067 Insert_After (With_Sys, Withn); 5068 Mark_Rewrite_Insertion (Withn); 5069 Set_Context_Installed (Withn); 5070 5071 return True; 5072 5073 -- Here if unit load failed 5074 5075 else 5076 Error_Msg_Name_1 := Name_System; 5077 Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit)); 5078 Error_Msg_N 5079 ("extension package `%.%` does not exist", 5080 Opt.System_Extend_Unit); 5081 return False; 5082 end if; 5083 end if; 5084 end Present_System_Aux; 5085 5086 ------------------------- 5087 -- Restore_Scope_Stack -- 5088 ------------------------- 5089 5090 procedure Restore_Scope_Stack (Handle_Use : Boolean := True) is 5091 E : Entity_Id; 5092 S : Entity_Id; 5093 Comp_Unit : Node_Id; 5094 In_Child : Boolean := False; 5095 Full_Vis : Boolean := True; 5096 SS_Last : constant Int := Scope_Stack.Last; 5097 5098 begin 5099 -- Restore visibility of previous scope stack, if any. 5100 5101 for J in reverse 0 .. Scope_Stack.Last loop 5102 exit when Scope_Stack.Table (J).Entity = Standard_Standard 5103 or else No (Scope_Stack.Table (J).Entity); 5104 5105 S := Scope_Stack.Table (J).Entity; 5106 5107 if not Is_Hidden_Open_Scope (S) then 5108 5109 -- If the parent scope is hidden, its entities are hidden as 5110 -- well, unless the entity is the instantiation currently 5111 -- being analyzed. 5112 5113 if not Is_Hidden_Open_Scope (Scope (S)) 5114 or else not Analyzed (Parent (S)) 5115 or else Scope (S) = Standard_Standard 5116 then 5117 Set_Is_Immediately_Visible (S, True); 5118 end if; 5119 5120 E := First_Entity (S); 5121 5122 while Present (E) loop 5123 if Is_Child_Unit (E) then 5124 Set_Is_Immediately_Visible (E, 5125 Is_Visible_Child_Unit (E) or else In_Open_Scopes (E)); 5126 else 5127 Set_Is_Immediately_Visible (E, True); 5128 end if; 5129 5130 Next_Entity (E); 5131 5132 if not Full_Vis then 5133 exit when E = First_Private_Entity (S); 5134 end if; 5135 end loop; 5136 5137 -- The visibility of child units (siblings of current compilation) 5138 -- must be restored in any case. Their declarations may appear 5139 -- after the private part of the parent. 5140 5141 if not Full_Vis 5142 and then Present (E) 5143 then 5144 while Present (E) loop 5145 if Is_Child_Unit (E) then 5146 Set_Is_Immediately_Visible (E, 5147 Is_Visible_Child_Unit (E) or else In_Open_Scopes (E)); 5148 end if; 5149 5150 Next_Entity (E); 5151 end loop; 5152 end if; 5153 end if; 5154 5155 if Is_Child_Unit (S) 5156 and not In_Child -- check only for current unit. 5157 then 5158 In_Child := True; 5159 5160 -- restore visibility of parents according to whether the child 5161 -- is private and whether we are in its visible part. 5162 5163 Comp_Unit := Parent (Unit_Declaration_Node (S)); 5164 5165 if Nkind (Comp_Unit) = N_Compilation_Unit 5166 and then Private_Present (Comp_Unit) 5167 then 5168 Full_Vis := True; 5169 5170 elsif (Ekind (S) = E_Package 5171 or else Ekind (S) = E_Generic_Package) 5172 and then (In_Private_Part (S) 5173 or else In_Package_Body (S)) 5174 then 5175 Full_Vis := True; 5176 5177 elsif (Ekind (S) = E_Procedure 5178 or else Ekind (S) = E_Function) 5179 and then Has_Completion (S) 5180 then 5181 Full_Vis := True; 5182 else 5183 Full_Vis := False; 5184 end if; 5185 else 5186 Full_Vis := True; 5187 end if; 5188 end loop; 5189 5190 if SS_Last >= Scope_Stack.First 5191 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 5192 and then Handle_Use 5193 then 5194 Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); 5195 end if; 5196 end Restore_Scope_Stack; 5197 5198 ---------------------- 5199 -- Save_Scope_Stack -- 5200 ---------------------- 5201 5202 procedure Save_Scope_Stack (Handle_Use : Boolean := True) is 5203 E : Entity_Id; 5204 S : Entity_Id; 5205 SS_Last : constant Int := Scope_Stack.Last; 5206 5207 begin 5208 if SS_Last >= Scope_Stack.First 5209 and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard 5210 then 5211 if Handle_Use then 5212 End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); 5213 end if; 5214 5215 -- If the call is from within a compilation unit, as when 5216 -- called from Rtsfind, make current entries in scope stack 5217 -- invisible while we analyze the new unit. 5218 5219 for J in reverse 0 .. SS_Last loop 5220 exit when Scope_Stack.Table (J).Entity = Standard_Standard 5221 or else No (Scope_Stack.Table (J).Entity); 5222 5223 S := Scope_Stack.Table (J).Entity; 5224 Set_Is_Immediately_Visible (S, False); 5225 E := First_Entity (S); 5226 5227 while Present (E) loop 5228 Set_Is_Immediately_Visible (E, False); 5229 Next_Entity (E); 5230 end loop; 5231 end loop; 5232 5233 end if; 5234 end Save_Scope_Stack; 5235 5236 ------------- 5237 -- Set_Use -- 5238 ------------- 5239 5240 procedure Set_Use (L : List_Id) is 5241 Decl : Node_Id; 5242 Pack_Name : Node_Id; 5243 Pack : Entity_Id; 5244 Id : Entity_Id; 5245 5246 begin 5247 if Present (L) then 5248 Decl := First (L); 5249 5250 while Present (Decl) loop 5251 if Nkind (Decl) = N_Use_Package_Clause then 5252 Chain_Use_Clause (Decl); 5253 Pack_Name := First (Names (Decl)); 5254 5255 while Present (Pack_Name) loop 5256 Pack := Entity (Pack_Name); 5257 5258 if Ekind (Pack) = E_Package 5259 and then Applicable_Use (Pack_Name) 5260 then 5261 Use_One_Package (Pack, Decl); 5262 end if; 5263 5264 Next (Pack_Name); 5265 end loop; 5266 5267 elsif Nkind (Decl) = N_Use_Type_Clause then 5268 Chain_Use_Clause (Decl); 5269 Id := First (Subtype_Marks (Decl)); 5270 5271 while Present (Id) loop 5272 if Entity (Id) /= Any_Type then 5273 Use_One_Type (Id); 5274 end if; 5275 5276 Next (Id); 5277 end loop; 5278 end if; 5279 5280 Next (Decl); 5281 end loop; 5282 end if; 5283 end Set_Use; 5284 5285 --------------------- 5286 -- Use_One_Package -- 5287 --------------------- 5288 5289 procedure Use_One_Package (P : Entity_Id; N : Node_Id) is 5290 Id : Entity_Id; 5291 Prev : Entity_Id; 5292 Current_Instance : Entity_Id := Empty; 5293 Real_P : Entity_Id; 5294 5295 begin 5296 if Ekind (P) /= E_Package then 5297 return; 5298 end if; 5299 5300 Set_In_Use (P); 5301 5302 -- Ada0Y (AI-50217): Check restriction. 5303 5304 if From_With_Type (P) then 5305 Error_Msg_N ("limited withed package cannot appear in use clause", N); 5306 end if; 5307 5308 -- Find enclosing instance, if any. 5309 5310 if In_Instance then 5311 Current_Instance := Current_Scope; 5312 5313 while not Is_Generic_Instance (Current_Instance) loop 5314 Current_Instance := Scope (Current_Instance); 5315 end loop; 5316 5317 if No (Hidden_By_Use_Clause (N)) then 5318 Set_Hidden_By_Use_Clause (N, New_Elmt_List); 5319 end if; 5320 end if; 5321 5322 -- If unit is a package renaming, indicate that the renamed 5323 -- package is also in use (the flags on both entities must 5324 -- remain consistent, and a subsequent use of either of them 5325 -- should be recognized as redundant). 5326 5327 if Present (Renamed_Object (P)) then 5328 Set_In_Use (Renamed_Object (P)); 5329 Real_P := Renamed_Object (P); 5330 else 5331 Real_P := P; 5332 end if; 5333 5334 -- Loop through entities in one package making them potentially 5335 -- use-visible. 5336 5337 Id := First_Entity (P); 5338 while Present (Id) 5339 and then Id /= First_Private_Entity (P) 5340 loop 5341 Prev := Current_Entity (Id); 5342 5343 while Present (Prev) loop 5344 if Is_Immediately_Visible (Prev) 5345 and then (not Is_Overloadable (Prev) 5346 or else not Is_Overloadable (Id) 5347 or else (Type_Conformant (Id, Prev))) 5348 then 5349 if No (Current_Instance) then 5350 5351 -- Potentially use-visible entity remains hidden 5352 5353 goto Next_Usable_Entity; 5354 5355 -- A use clause within an instance hides outer global 5356 -- entities, which are not used to resolve local entities 5357 -- in the instance. Note that the predefined entities in 5358 -- Standard could not have been hidden in the generic by 5359 -- a use clause, and therefore remain visible. Other 5360 -- compilation units whose entities appear in Standard must 5361 -- be hidden in an instance. 5362 5363 -- To determine whether an entity is external to the instance 5364 -- we compare the scope depth of its scope with that of the 5365 -- current instance. However, a generic actual of a subprogram 5366 -- instance is declared in the wrapper package but will not be 5367 -- hidden by a use-visible entity. 5368 5369 elsif not Is_Hidden (Id) 5370 and then not Is_Wrapper_Package (Scope (Prev)) 5371 and then Scope_Depth (Scope (Prev)) < 5372 Scope_Depth (Current_Instance) 5373 and then (Scope (Prev) /= Standard_Standard 5374 or else Sloc (Prev) > Standard_Location) 5375 then 5376 Set_Is_Potentially_Use_Visible (Id); 5377 Set_Is_Immediately_Visible (Prev, False); 5378 Append_Elmt (Prev, Hidden_By_Use_Clause (N)); 5379 end if; 5380 5381 -- A user-defined operator is not use-visible if the 5382 -- predefined operator for the type is immediately visible, 5383 -- which is the case if the type of the operand is in an open 5384 -- scope. This does not apply to user-defined operators that 5385 -- have operands of different types, because the predefined 5386 -- mixed mode operations (multiplication and division) apply to 5387 -- universal types and do not hide anything. 5388 5389 elsif Ekind (Prev) = E_Operator 5390 and then Operator_Matches_Spec (Prev, Id) 5391 and then In_Open_Scopes 5392 (Scope (Base_Type (Etype (First_Formal (Id))))) 5393 and then (No (Next_Formal (First_Formal (Id))) 5394 or else Etype (First_Formal (Id)) 5395 = Etype (Next_Formal (First_Formal (Id))) 5396 or else Chars (Prev) = Name_Op_Expon) 5397 then 5398 goto Next_Usable_Entity; 5399 end if; 5400 5401 Prev := Homonym (Prev); 5402 end loop; 5403 5404 -- On exit, we know entity is not hidden, unless it is private. 5405 5406 if not Is_Hidden (Id) 5407 and then ((not Is_Child_Unit (Id)) 5408 or else Is_Visible_Child_Unit (Id)) 5409 then 5410 Set_Is_Potentially_Use_Visible (Id); 5411 5412 if Is_Private_Type (Id) 5413 and then Present (Full_View (Id)) 5414 then 5415 Set_Is_Potentially_Use_Visible (Full_View (Id)); 5416 end if; 5417 end if; 5418 5419 <<Next_Usable_Entity>> 5420 Next_Entity (Id); 5421 end loop; 5422 5423 -- Child units are also made use-visible by a use clause, but they 5424 -- may appear after all visible declarations in the parent entity list. 5425 5426 while Present (Id) loop 5427 5428 if Is_Child_Unit (Id) 5429 and then Is_Visible_Child_Unit (Id) 5430 then 5431 Set_Is_Potentially_Use_Visible (Id); 5432 end if; 5433 5434 Next_Entity (Id); 5435 end loop; 5436 5437 if Chars (Real_P) = Name_System 5438 and then Scope (Real_P) = Standard_Standard 5439 and then Present_System_Aux (N) 5440 then 5441 Use_One_Package (System_Aux_Id, N); 5442 end if; 5443 5444 end Use_One_Package; 5445 5446 ------------------ 5447 -- Use_One_Type -- 5448 ------------------ 5449 5450 procedure Use_One_Type (Id : Node_Id) is 5451 T : Entity_Id; 5452 Op_List : Elist_Id; 5453 Elmt : Elmt_Id; 5454 5455 begin 5456 -- It is the type determined by the subtype mark (8.4(8)) whose 5457 -- operations become potentially use-visible. 5458 5459 T := Base_Type (Entity (Id)); 5460 5461 Set_Redundant_Use 5462 (Id, 5463 In_Use (T) 5464 or else Is_Potentially_Use_Visible (T) 5465 or else In_Use (Scope (T))); 5466 5467 if In_Open_Scopes (Scope (T)) then 5468 null; 5469 5470 -- If the subtype mark designates a subtype in a different package, 5471 -- we have to check that the parent type is visible, otherwise the 5472 -- use type clause is a noop. Not clear how to do that??? 5473 5474 elsif not Redundant_Use (Id) then 5475 Set_In_Use (T); 5476 Op_List := Collect_Primitive_Operations (T); 5477 Elmt := First_Elmt (Op_List); 5478 5479 while Present (Elmt) loop 5480 5481 if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol 5482 or else Chars (Node (Elmt)) in Any_Operator_Name) 5483 and then not Is_Hidden (Node (Elmt)) 5484 then 5485 Set_Is_Potentially_Use_Visible (Node (Elmt)); 5486 end if; 5487 5488 Next_Elmt (Elmt); 5489 end loop; 5490 end if; 5491 end Use_One_Type; 5492 5493 ---------------- 5494 -- Write_Info -- 5495 ---------------- 5496 5497 procedure Write_Info is 5498 Id : Entity_Id := First_Entity (Current_Scope); 5499 5500 begin 5501 -- No point in dumping standard entities 5502 5503 if Current_Scope = Standard_Standard then 5504 return; 5505 end if; 5506 5507 Write_Str ("========================================================"); 5508 Write_Eol; 5509 Write_Str (" Defined Entities in "); 5510 Write_Name (Chars (Current_Scope)); 5511 Write_Eol; 5512 Write_Str ("========================================================"); 5513 Write_Eol; 5514 5515 if No (Id) then 5516 Write_Str ("-- none --"); 5517 Write_Eol; 5518 5519 else 5520 while Present (Id) loop 5521 Write_Entity_Info (Id, " "); 5522 Next_Entity (Id); 5523 end loop; 5524 end if; 5525 5526 if Scope (Current_Scope) = Standard_Standard then 5527 5528 -- Print information on the current unit itself 5529 5530 Write_Entity_Info (Current_Scope, " "); 5531 end if; 5532 5533 Write_Eol; 5534 end Write_Info; 5535 5536 ----------------- 5537 -- Write_Scopes -- 5538 ----------------- 5539 5540 procedure Write_Scopes is 5541 S : Entity_Id; 5542 5543 begin 5544 for J in reverse 1 .. Scope_Stack.Last loop 5545 S := Scope_Stack.Table (J).Entity; 5546 Write_Int (Int (S)); 5547 Write_Str (" === "); 5548 Write_Name (Chars (S)); 5549 Write_Eol; 5550 end loop; 5551 end Write_Scopes; 5552 5553end Sem_Ch8; 5554