| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 8 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Exp_Disp; use Exp_Disp; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with Ghost; use Ghost; |
| with Impunit; use Impunit; |
| with Lib; use Lib; |
| with Lib.Load; use Lib.Load; |
| with Lib.Xref; use Lib.Xref; |
| with Namet; use Namet; |
| with Namet.Sp; use Namet.Sp; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch4; use Sem_Ch4; |
| with Sem_Ch6; use Sem_Ch6; |
| with Sem_Ch10; use Sem_Ch10; |
| with Sem_Ch12; use Sem_Ch12; |
| with Sem_Ch13; use Sem_Ch13; |
| with Sem_Dim; use Sem_Dim; |
| with Sem_Disp; use Sem_Disp; |
| with Sem_Dist; use Sem_Dist; |
| with Sem_Elab; use Sem_Elab; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Prag; use Sem_Prag; |
| with Sem_Res; use Sem_Res; |
| with Sem_Util; use Sem_Util; |
| with Sem_Type; use Sem_Type; |
| with Stand; use Stand; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Sinfo.CN; use Sinfo.CN; |
| with Snames; use Snames; |
| with Style; |
| with Table; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| with Warnsw; use Warnsw; |
| |
| package body Sem_Ch8 is |
| |
| ------------------------------------ |
| -- Visibility and Name Resolution -- |
| ------------------------------------ |
| |
| -- This package handles name resolution and the collection of possible |
| -- interpretations for overloaded names, prior to overload resolution. |
| |
| -- Name resolution is the process that establishes a mapping between source |
| -- identifiers and the entities they denote at each point in the program. |
| -- Each entity is represented by a defining occurrence. Each identifier |
| -- that denotes an entity points to the corresponding defining occurrence. |
| -- This is the entity of the applied occurrence. Each occurrence holds |
| -- an index into the names table, where source identifiers are stored. |
| |
| -- Each entry in the names table for an identifier or designator uses the |
| -- Info pointer to hold a link to the currently visible entity that has |
| -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id |
| -- in package Sem_Util). The visibility is initialized at the beginning of |
| -- semantic processing to make entities in package Standard immediately |
| -- visible. The visibility table is used in a more subtle way when |
| -- compiling subunits (see below). |
| |
| -- Entities that have the same name (i.e. homonyms) are chained. In the |
| -- case of overloaded entities, this chain holds all the possible meanings |
| -- of a given identifier. The process of overload resolution uses type |
| -- information to select from this chain the unique meaning of a given |
| -- identifier. |
| |
| -- Entities are also chained in their scope, through the Next_Entity link. |
| -- As a consequence, the name space is organized as a sparse matrix, where |
| -- each row corresponds to a scope, and each column to a source identifier. |
| -- Open scopes, that is to say scopes currently being compiled, have their |
| -- corresponding rows of entities in order, innermost scope first. |
| |
| -- The scopes of packages that are mentioned in context clauses appear in |
| -- no particular order, interspersed among open scopes. This is because |
| -- in the course of analyzing the context of a compilation, a package |
| -- declaration is first an open scope, and subsequently an element of the |
| -- context. If subunits or child units are present, a parent unit may |
| -- appear under various guises at various times in the compilation. |
| |
| -- When the compilation of the innermost scope is complete, the entities |
| -- defined therein are no longer visible. If the scope is not a package |
| -- declaration, these entities are never visible subsequently, and can be |
| -- removed from visibility chains. If the scope is a package declaration, |
| -- its visible declarations may still be accessible. Therefore the entities |
| -- defined in such a scope are left on the visibility chains, and only |
| -- their visibility (immediately visibility or potential use-visibility) |
| -- is affected. |
| |
| -- The ordering of homonyms on their chain does not necessarily follow |
| -- the order of their corresponding scopes on the scope stack. For |
| -- example, if package P and the enclosing scope both contain entities |
| -- named E, then when compiling the package body the chain for E will |
| -- hold the global entity first, and the local one (corresponding to |
| -- the current inner scope) next. As a result, name resolution routines |
| -- do not assume any relative ordering of the homonym chains, either |
| -- for scope nesting or to order of appearance of context clauses. |
| |
| -- When compiling a child unit, entities in the parent scope are always |
| -- immediately visible. When compiling the body of a child unit, private |
| -- entities in the parent must also be made immediately visible. There |
| -- are separate routines to make the visible and private declarations |
| -- visible at various times (see package Sem_Ch7). |
| |
| -- +--------+ +-----+ |
| -- | In use |-------->| EU1 |--------------------------> |
| -- +--------+ +-----+ |
| -- | | |
| -- +--------+ +-----+ +-----+ |
| -- | Stand. |---------------->| ES1 |--------------->| ES2 |---> |
| -- +--------+ +-----+ +-----+ |
| -- | | |
| -- +---------+ | +-----+ |
| -- | with'ed |------------------------------>| EW2 |---> |
| -- +---------+ | +-----+ |
| -- | | |
| -- +--------+ +-----+ +-----+ |
| -- | Scope2 |---------------->| E12 |--------------->| E22 |---> |
| -- +--------+ +-----+ +-----+ |
| -- | | |
| -- +--------+ +-----+ +-----+ |
| -- | Scope1 |---------------->| E11 |--------------->| E12 |---> |
| -- +--------+ +-----+ +-----+ |
| -- ^ | | |
| -- | | | |
| -- | +---------+ | | |
| -- | | with'ed |-----------------------------------------> |
| -- | +---------+ | | |
| -- | | | |
| -- Scope stack | | |
| -- (innermost first) | | |
| -- +----------------------------+ |
| -- Names table => | Id1 | | | | Id2 | |
| -- +----------------------------+ |
| |
| -- Name resolution must deal with several syntactic forms: simple names, |
| -- qualified names, indexed names, and various forms of calls. |
| |
| -- Each identifier points to an entry in the names table. The resolution |
| -- of a simple name consists in traversing the homonym chain, starting |
| -- from the names table. If an entry is immediately visible, it is the one |
| -- designated by the identifier. If only potentially use-visible entities |
| -- are on the chain, we must verify that they do not hide each other. If |
| -- the entity we find is overloadable, we collect all other overloadable |
| -- entities on the chain as long as they are not hidden. |
| -- |
| -- To resolve expanded names, we must find the entity at the intersection |
| -- of the entity chain for the scope (the prefix) and the homonym chain |
| -- for the selector. In general, homonym chains will be much shorter than |
| -- entity chains, so it is preferable to start from the names table as |
| -- well. If the entity found is overloadable, we must collect all other |
| -- interpretations that are defined in the scope denoted by the prefix. |
| |
| -- For records, protected types, and tasks, their local entities are |
| -- removed from visibility chains on exit from the corresponding scope. |
| -- From the outside, these entities are always accessed by selected |
| -- notation, and the entity chain for the record type, protected type, |
| -- etc. is traversed sequentially in order to find the designated entity. |
| |
| -- The discriminants of a type and the operations of a protected type or |
| -- task are unchained on exit from the first view of the type, (such as |
| -- a private or incomplete type declaration, or a protected type speci- |
| -- fication) and re-chained when compiling the second view. |
| |
| -- In the case of operators, we do not make operators on derived types |
| -- explicit. As a result, the notation P."+" may denote either a user- |
| -- defined function with name "+", or else an implicit declaration of the |
| -- operator "+" in package P. The resolution of expanded names always |
| -- tries to resolve an operator name as such an implicitly defined entity, |
| -- in addition to looking for explicit declarations. |
| |
| -- All forms of names that denote entities (simple names, expanded names, |
| -- character literals in some cases) have a Entity attribute, which |
| -- identifies the entity denoted by the name. |
| |
| --------------------- |
| -- The Scope Stack -- |
| --------------------- |
| |
| -- The Scope stack keeps track of the scopes currently been compiled. |
| -- Every entity that contains declarations (including records) is placed |
| -- on the scope stack while it is being processed, and removed at the end. |
| -- Whenever a non-package scope is exited, the entities defined therein |
| -- are removed from the visibility table, so that entities in outer scopes |
| -- become visible (see previous description). On entry to Sem, the scope |
| -- stack only contains the package Standard. As usual, subunits complicate |
| -- this picture ever so slightly. |
| |
| -- The Rtsfind mechanism can force a call to Semantics while another |
| -- compilation is in progress. The unit retrieved by Rtsfind must be |
| -- compiled in its own context, and has no access to the visibility of |
| -- the unit currently being compiled. The procedures Save_Scope_Stack and |
| -- Restore_Scope_Stack make entities in current open scopes invisible |
| -- before compiling the retrieved unit, and restore the compilation |
| -- environment afterwards. |
| |
| ------------------------ |
| -- Compiling subunits -- |
| ------------------------ |
| |
| -- Subunits must be compiled in the environment of the corresponding stub, |
| -- that is to say with the same visibility into the parent (and its |
| -- context) that is available at the point of the stub declaration, but |
| -- with the additional visibility provided by the context clause of the |
| -- subunit itself. As a result, compilation of a subunit forces compilation |
| -- of the parent (see description in lib-). At the point of the stub |
| -- declaration, Analyze is called recursively to compile the proper body of |
| -- the subunit, but without reinitializing the names table, nor the scope |
| -- stack (i.e. standard is not pushed on the stack). In this fashion the |
| -- context of the subunit is added to the context of the parent, and the |
| -- subunit is compiled in the correct environment. Note that in the course |
| -- of processing the context of a subunit, Standard will appear twice on |
| -- the scope stack: once for the parent of the subunit, and once for the |
| -- unit in the context clause being compiled. However, the two sets of |
| -- entities are not linked by homonym chains, so that the compilation of |
| -- any context unit happens in a fresh visibility environment. |
| |
| ------------------------------- |
| -- Processing of USE Clauses -- |
| ------------------------------- |
| |
| -- Every defining occurrence has a flag indicating if it is potentially use |
| -- visible. Resolution of simple names examines this flag. The processing |
| -- of use clauses consists in setting this flag on all visible entities |
| -- defined in the corresponding package. On exit from the scope of the use |
| -- clause, the corresponding flag must be reset. However, a package may |
| -- appear in several nested use clauses (pathological but legal, alas) |
| -- which forces us to use a slightly more involved scheme: |
| |
| -- a) The defining occurrence for a package holds a flag -In_Use- to |
| -- indicate that it is currently in the scope of a use clause. If a |
| -- redundant use clause is encountered, then the corresponding occurrence |
| -- of the package name is flagged -Redundant_Use-. |
| |
| -- b) On exit from a scope, the use clauses in its declarative part are |
| -- scanned. The visibility flag is reset in all entities declared in |
| -- package named in a use clause, as long as the package is not flagged |
| -- as being in a redundant use clause (in which case the outer use |
| -- clause is still in effect, and the direct visibility of its entities |
| -- must be retained). |
| |
| -- Note that entities are not removed from their homonym chains on exit |
| -- from the package specification. A subsequent use clause does not need |
| -- to rechain the visible entities, but only to establish their direct |
| -- visibility. |
| |
| ----------------------------------- |
| -- Handling private declarations -- |
| ----------------------------------- |
| |
| -- The principle that each entity has a single defining occurrence clashes |
| -- with the presence of two separate definitions for private types: the |
| -- first is the private type declaration, and second is the full type |
| -- declaration. It is important that all references to the type point to |
| -- the same defining occurrence, namely the first one. To enforce the two |
| -- separate views of the entity, the corresponding information is swapped |
| -- between the two declarations. Outside of the package, the defining |
| -- occurrence only contains the private declaration information, while in |
| -- the private part and the body of the package the defining occurrence |
| -- contains the full declaration. To simplify the swap, the defining |
| -- occurrence that currently holds the private declaration points to the |
| -- full declaration. During semantic processing the defining occurrence |
| -- also points to a list of private dependents, that is to say access types |
| -- or composite types whose designated types or component types are |
| -- subtypes or derived types of the private type in question. After the |
| -- full declaration has been seen, the private dependents are updated to |
| -- indicate that they have full definitions. |
| |
| ------------------------------------ |
| -- Handling of Undefined Messages -- |
| ------------------------------------ |
| |
| -- In normal mode, only the first use of an undefined identifier generates |
| -- a message. The table Urefs is used to record error messages that have |
| -- been issued so that second and subsequent ones do not generate further |
| -- messages. However, the second reference causes text to be added to the |
| -- original undefined message noting "(more references follow)". The |
| -- full error list option (-gnatf) forces messages to be generated for |
| -- every reference and disconnects the use of this table. |
| |
| type Uref_Entry is record |
| Node : Node_Id; |
| -- Node for identifier for which original message was posted. The |
| -- Chars field of this identifier is used to detect later references |
| -- to the same identifier. |
| |
| Err : Error_Msg_Id; |
| -- Records error message Id of original undefined message. Reset to |
| -- No_Error_Msg after the second occurrence, where it is used to add |
| -- text to the original message as described above. |
| |
| Nvis : Boolean; |
| -- Set if the message is not visible rather than undefined |
| |
| Loc : Source_Ptr; |
| -- Records location of error message. Used to make sure that we do |
| -- not consider a, b : undefined as two separate instances, which |
| -- would otherwise happen, since the parser converts this sequence |
| -- to a : undefined; b : undefined. |
| |
| end record; |
| |
| package Urefs is new Table.Table ( |
| Table_Component_Type => Uref_Entry, |
| Table_Index_Type => Nat, |
| Table_Low_Bound => 1, |
| Table_Initial => 10, |
| Table_Increment => 100, |
| Table_Name => "Urefs"); |
| |
| Candidate_Renaming : Entity_Id; |
| -- Holds a candidate interpretation that appears in a subprogram renaming |
| -- declaration and does not match the given specification, but matches at |
| -- least on the first formal. Allows better error message when given |
| -- specification omits defaulted parameters, a common error. |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Analyze_Generic_Renaming |
| (N : Node_Id; |
| K : Entity_Kind); |
| -- Common processing for all three kinds of generic renaming declarations. |
| -- Enter new name and indicate that it renames the generic unit. |
| |
| procedure Analyze_Renamed_Character |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean); |
| -- Renamed entity is given by a character literal, which must belong |
| -- to the return type of the new entity. Is_Body indicates whether the |
| -- declaration is a renaming_as_body. If the original declaration has |
| -- already been frozen (because of an intervening body, e.g.) the body of |
| -- the function must be built now. The same applies to the following |
| -- various renaming procedures. |
| |
| procedure Analyze_Renamed_Dereference |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean); |
| -- Renamed entity is given by an explicit dereference. Prefix must be a |
| -- conformant access_to_subprogram type. |
| |
| procedure Analyze_Renamed_Entry |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean); |
| -- If the renamed entity in a subprogram renaming is an entry or protected |
| -- subprogram, build a body for the new entity whose only statement is a |
| -- call to the renamed entity. |
| |
| procedure Analyze_Renamed_Family_Member |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean); |
| -- Used when the renamed entity is an indexed component. The prefix must |
| -- denote an entry family. |
| |
| procedure Analyze_Renamed_Primitive_Operation |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean); |
| -- If the renamed entity in a subprogram renaming is a primitive operation |
| -- or a class-wide operation in prefix form, save the target object, |
| -- which must be added to the list of actuals in any subsequent call. |
| -- The renaming operation is intrinsic because the compiler must in |
| -- fact generate a wrapper for it (6.3.1 (10 1/2)). |
| |
| procedure Attribute_Renaming (N : Node_Id); |
| -- Analyze renaming of attribute as subprogram. The renaming declaration N |
| -- is rewritten as a subprogram body that returns the attribute reference |
| -- applied to the formals of the function. |
| |
| procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); |
| -- Set Entity, with style check if need be. For a discriminant reference, |
| -- replace by the corresponding discriminal, i.e. the parameter of the |
| -- initialization procedure that corresponds to the discriminant. |
| |
| procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); |
| -- A renaming_as_body may occur after the entity of the original decla- |
| -- ration has been frozen. In that case, the body of the new entity must |
| -- be built now, because the usual mechanism of building the renamed |
| -- body at the point of freezing will not work. Subp is the subprogram |
| -- for which N provides the Renaming_As_Body. |
| |
| procedure Check_In_Previous_With_Clause (N, Nam : Node_Id); |
| -- N is a use_package clause and Nam the package name, or N is a use_type |
| -- clause and Nam is the prefix of the type name. In either case, verify |
| -- that the package is visible at that point in the context: either it |
| -- appears in a previous with_clause, or because it is a fully qualified |
| -- name and the root ancestor appears in a previous with_clause. |
| |
| procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id); |
| -- Verify that the entity in a renaming declaration that is a library unit |
| -- is itself a library unit and not a nested unit or subunit. Also check |
| -- that if the renaming is a child unit of a generic parent, then the |
| -- renamed unit must also be a child unit of that parent. Finally, verify |
| -- that a renamed generic unit is not an implicit child declared within |
| -- an instance of the parent. |
| |
| procedure Chain_Use_Clause (N : Node_Id); |
| -- Chain use clause onto list of uses clauses headed by First_Use_Clause in |
| -- the proper scope table entry. This is usually the current scope, but it |
| -- will be an inner scope when installing the use clauses of the private |
| -- declarations of a parent unit prior to compiling the private part of a |
| -- child unit. This chain is traversed when installing/removing use clauses |
| -- when compiling a subunit or instantiating a generic body on the fly, |
| -- when it is necessary to save and restore full environments. |
| |
| function Enclosing_Instance return Entity_Id; |
| -- In an instance nested within another one, several semantic checks are |
| -- unnecessary because the legality of the nested instance has been checked |
| -- in the enclosing generic unit. This applies in particular to legality |
| -- checks on actuals for formal subprograms of the inner instance, which |
| -- are checked as subprogram renamings, and may be complicated by confusion |
| -- in private/full views. This function returns the instance enclosing the |
| -- current one if there is such, else it returns Empty. |
| -- |
| -- If the renaming determines the entity for the default of a formal |
| -- subprogram nested within another instance, choose the innermost |
| -- candidate. This is because if the formal has a box, and we are within |
| -- an enclosing instance where some candidate interpretations are local |
| -- to this enclosing instance, we know that the default was properly |
| -- resolved when analyzing the generic, so we prefer the local |
| -- candidates to those that are external. This is not always the case |
| -- but is a reasonable heuristic on the use of nested generics. The |
| -- proper solution requires a full renaming model. |
| |
| function Entity_Of_Unit (U : Node_Id) return Entity_Id; |
| -- Return the appropriate entity for determining which unit has a deeper |
| -- scope: the defining entity for U, unless U is a package instance, in |
| -- which case we retrieve the entity of the instance spec. |
| |
| procedure Error_Missing_With_Of_Known_Unit (Pkg : Node_Id); |
| -- Display an error message denoting a "with" is missing for a given known |
| -- package Pkg with its full path name. |
| |
| procedure Find_Expanded_Name (N : Node_Id); |
| -- The input is a selected component known to be an expanded name. Verify |
| -- legality of selector given the scope denoted by prefix, and change node |
| -- N into a expanded name with a properly set Entity field. |
| |
| function Find_First_Use (Use_Clause : Node_Id) return Node_Id; |
| -- Find the most previous use clause (that is, the first one to appear in |
| -- the source) by traversing the previous clause chain that exists in both |
| -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes. |
| |
| function Find_Renamed_Entity |
| (N : Node_Id; |
| Nam : Node_Id; |
| New_S : Entity_Id; |
| Is_Actual : Boolean := False) return Entity_Id; |
| -- Find the renamed entity that corresponds to the given parameter profile |
| -- in a subprogram renaming declaration. The renamed entity may be an |
| -- operator, a subprogram, an entry, or a protected operation. Is_Actual |
| -- indicates that the renaming is the one generated for an actual subpro- |
| -- gram in an instance, for which special visibility checks apply. |
| |
| function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; |
| -- Find a type derived from Character or Wide_Character in the prefix of N. |
| -- Used to resolved qualified names whose selector is a character literal. |
| |
| function Has_Private_With (E : Entity_Id) return Boolean; |
| -- Ada 2005 (AI-262): Determines if the current compilation unit has a |
| -- private with on E. |
| |
| function Has_Components (Typ : Entity_Id) return Boolean; |
| -- Determine if given type has components, i.e. is either a record type or |
| -- type or a type that has discriminants. |
| |
| function Has_Implicit_Operator (N : Node_Id) return Boolean; |
| -- N is an expanded name whose selector is an operator name (e.g. P."+"). |
| -- Determine if N denotes an operator implicitly declared in prefix P: P's |
| -- declarative part contains an implicit declaration of an operator if it |
| -- has a declaration of a type to which one of the predefined operators |
| -- apply. The existence of this routine is an implementation artifact. A |
| -- more straightforward but more space-consuming choice would be to make |
| -- all inherited operators explicit in the symbol table. |
| |
| procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id); |
| -- A subprogram defined by a renaming declaration inherits the parameter |
| -- profile of the renamed entity. The subtypes given in the subprogram |
| -- specification are discarded and replaced with those of the renamed |
| -- subprogram, which are then used to recheck the default values. |
| |
| function Most_Descendant_Use_Clause |
| (Clause1 : Entity_Id; |
| Clause2 : Entity_Id) return Entity_Id; |
| -- Determine which use clause parameter is the most descendant in terms of |
| -- scope. |
| |
| procedure Premature_Usage (N : Node_Id); |
| -- Diagnose usage of an entity before it is visible |
| |
| procedure Use_One_Package |
| (N : Node_Id; |
| Pack_Name : Entity_Id := Empty; |
| Force : Boolean := False); |
| -- Make visible entities declared in package P potentially use-visible |
| -- in the current context. Also used in the analysis of subunits, when |
| -- re-installing use clauses of parent units. N is the use_clause that |
| -- names P (and possibly other packages). |
| |
| procedure Use_One_Type |
| (Id : Node_Id; |
| Installed : Boolean := False; |
| Force : Boolean := False); |
| -- Id is the subtype mark from a use_type_clause. This procedure makes |
| -- the primitive operators of the type potentially use-visible. The |
| -- boolean flag Installed indicates that the clause is being reinstalled |
| -- after previous analysis, and primitive operations are already chained |
| -- on the Used_Operations list of the clause. |
| |
| procedure Write_Info; |
| -- Write debugging information on entities declared in current scope |
| |
| -------------------------------- |
| -- Analyze_Exception_Renaming -- |
| -------------------------------- |
| |
| -- The language only allows a single identifier, but the tree holds an |
| -- identifier list. The parser has already issued an error message if |
| -- there is more than one element in the list. |
| |
| procedure Analyze_Exception_Renaming (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Entity (N); |
| Nam : constant Node_Id := Name (N); |
| |
| begin |
| Enter_Name (Id); |
| Analyze (Nam); |
| |
| Mutate_Ekind (Id, E_Exception); |
| Set_Etype (Id, Standard_Exception_Type); |
| Set_Is_Pure (Id, Is_Pure (Current_Scope)); |
| |
| if Is_Entity_Name (Nam) |
| and then Present (Entity (Nam)) |
| and then Ekind (Entity (Nam)) = E_Exception |
| then |
| if Present (Renamed_Entity (Entity (Nam))) then |
| Set_Renamed_Entity (Id, Renamed_Entity (Entity (Nam))); |
| else |
| Set_Renamed_Entity (Id, Entity (Nam)); |
| end if; |
| |
| -- The exception renaming declaration may become Ghost if it renames |
| -- a Ghost entity. |
| |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| else |
| Error_Msg_N ("invalid exception name in renaming", Nam); |
| end if; |
| |
| -- Implementation-defined aspect specifications can appear in a renaming |
| -- declaration, but not language-defined ones. The call to procedure |
| -- Analyze_Aspect_Specifications will take care of this error check. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Id); |
| end if; |
| end Analyze_Exception_Renaming; |
| |
| --------------------------- |
| -- Analyze_Expanded_Name -- |
| --------------------------- |
| |
| procedure Analyze_Expanded_Name (N : Node_Id) is |
| begin |
| -- If the entity pointer is already set, this is an internal node, or a |
| -- node that is analyzed more than once, after a tree modification. In |
| -- such a case there is no resolution to perform, just set the type. In |
| -- either case, start by analyzing the prefix. |
| |
| Analyze (Prefix (N)); |
| |
| if Present (Entity (N)) then |
| if Is_Type (Entity (N)) then |
| Set_Etype (N, Entity (N)); |
| else |
| Set_Etype (N, Etype (Entity (N))); |
| end if; |
| |
| else |
| Find_Expanded_Name (N); |
| end if; |
| |
| -- In either case, propagate dimension of entity to expanded name |
| |
| Analyze_Dimension (N); |
| end Analyze_Expanded_Name; |
| |
| --------------------------------------- |
| -- Analyze_Generic_Function_Renaming -- |
| --------------------------------------- |
| |
| procedure Analyze_Generic_Function_Renaming (N : Node_Id) is |
| begin |
| Analyze_Generic_Renaming (N, E_Generic_Function); |
| end Analyze_Generic_Function_Renaming; |
| |
| -------------------------------------- |
| -- Analyze_Generic_Package_Renaming -- |
| -------------------------------------- |
| |
| procedure Analyze_Generic_Package_Renaming (N : Node_Id) is |
| begin |
| -- Test for the Text_IO special unit case here, since we may be renaming |
| -- one of the subpackages of Text_IO, then join common routine. |
| |
| Check_Text_IO_Special_Unit (Name (N)); |
| |
| Analyze_Generic_Renaming (N, E_Generic_Package); |
| end Analyze_Generic_Package_Renaming; |
| |
| ---------------------------------------- |
| -- Analyze_Generic_Procedure_Renaming -- |
| ---------------------------------------- |
| |
| procedure Analyze_Generic_Procedure_Renaming (N : Node_Id) is |
| begin |
| Analyze_Generic_Renaming (N, E_Generic_Procedure); |
| end Analyze_Generic_Procedure_Renaming; |
| |
| ------------------------------ |
| -- Analyze_Generic_Renaming -- |
| ------------------------------ |
| |
| procedure Analyze_Generic_Renaming |
| (N : Node_Id; |
| K : Entity_Kind) |
| is |
| New_P : constant Entity_Id := Defining_Entity (N); |
| Inst : Boolean := False; |
| Old_P : Entity_Id; |
| |
| begin |
| if Name (N) = Error then |
| return; |
| end if; |
| |
| Generate_Definition (New_P); |
| |
| if Current_Scope /= Standard_Standard then |
| Set_Is_Pure (New_P, Is_Pure (Current_Scope)); |
| end if; |
| |
| if Nkind (Name (N)) = N_Selected_Component then |
| Check_Generic_Child_Unit (Name (N), Inst); |
| else |
| Analyze (Name (N)); |
| end if; |
| |
| if not Is_Entity_Name (Name (N)) then |
| Error_Msg_N ("expect entity name in renaming declaration", Name (N)); |
| Old_P := Any_Id; |
| else |
| Old_P := Entity (Name (N)); |
| end if; |
| |
| Enter_Name (New_P); |
| Mutate_Ekind (New_P, K); |
| |
| if Etype (Old_P) = Any_Type then |
| null; |
| |
| elsif Ekind (Old_P) /= K then |
| Error_Msg_N ("invalid generic unit name", Name (N)); |
| |
| else |
| if Present (Renamed_Entity (Old_P)) then |
| Set_Renamed_Entity (New_P, Renamed_Entity (Old_P)); |
| else |
| Set_Renamed_Entity (New_P, Old_P); |
| end if; |
| |
| -- The generic renaming declaration may become Ghost if it renames a |
| -- Ghost entity. |
| |
| Mark_Ghost_Renaming (N, Old_P); |
| |
| Set_Is_Pure (New_P, Is_Pure (Old_P)); |
| Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P)); |
| |
| Set_Etype (New_P, Etype (Old_P)); |
| Set_Has_Completion (New_P); |
| |
| if In_Open_Scopes (Old_P) then |
| Error_Msg_N ("within its scope, generic denotes its instance", N); |
| end if; |
| |
| -- For subprograms, propagate the Intrinsic flag, to allow, e.g. |
| -- renamings and subsequent instantiations of Unchecked_Conversion. |
| |
| if Is_Generic_Subprogram (Old_P) then |
| Set_Is_Intrinsic_Subprogram |
| (New_P, Is_Intrinsic_Subprogram (Old_P)); |
| end if; |
| |
| Check_Library_Unit_Renaming (N, Old_P); |
| end if; |
| |
| -- Implementation-defined aspect specifications can appear in a renaming |
| -- declaration, but not language-defined ones. The call to procedure |
| -- Analyze_Aspect_Specifications will take care of this error check. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, New_P); |
| end if; |
| end Analyze_Generic_Renaming; |
| |
| ----------------------------- |
| -- Analyze_Object_Renaming -- |
| ----------------------------- |
| |
| procedure Analyze_Object_Renaming (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Nam : constant Node_Id := Name (N); |
| Is_Object_Ref : Boolean; |
| Dec : Node_Id; |
| T : Entity_Id; |
| T2 : Entity_Id; |
| Q : Node_Id; |
| |
| procedure Check_Constrained_Object; |
| -- If the nominal type is unconstrained but the renamed object is |
| -- constrained, as can happen with renaming an explicit dereference or |
| -- a function return, build a constrained subtype from the object. If |
| -- the renaming is for a formal in an accept statement, the analysis |
| -- has already established its actual subtype. This is only relevant |
| -- if the renamed object is an explicit dereference. |
| |
| function Get_Object_Name (Nod : Node_Id) return Node_Id; |
| -- Obtain the name of the object from node Nod which is being renamed by |
| -- the object renaming declaration N. |
| |
| function Find_Raise_Node (N : Node_Id) return Traverse_Result; |
| -- Process one node in search for N_Raise_xxx_Error nodes. |
| -- Return Abandon if found, OK otherwise. |
| |
| --------------------- |
| -- Find_Raise_Node -- |
| --------------------- |
| |
| function Find_Raise_Node (N : Node_Id) return Traverse_Result is |
| begin |
| if Nkind (N) in N_Raise_xxx_Error then |
| return Abandon; |
| else |
| return OK; |
| end if; |
| end Find_Raise_Node; |
| |
| ------------------------ |
| -- No_Raise_xxx_Error -- |
| ------------------------ |
| |
| function No_Raise_xxx_Error is new Traverse_Func (Find_Raise_Node); |
| -- Traverse tree to look for a N_Raise_xxx_Error node and returns |
| -- Abandon if so and OK if none found. |
| |
| ------------------------------ |
| -- Check_Constrained_Object -- |
| ------------------------------ |
| |
| procedure Check_Constrained_Object is |
| Typ : constant Entity_Id := Etype (Nam); |
| Subt : Entity_Id; |
| Loop_Scheme : Node_Id; |
| |
| begin |
| if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference |
| and then Is_Composite_Type (Typ) |
| and then not Is_Constrained (Typ) |
| and then not Has_Unknown_Discriminants (Typ) |
| and then Expander_Active |
| then |
| -- If Actual_Subtype is already set, nothing to do |
| |
| if Ekind (Id) in E_Variable | E_Constant |
| and then Present (Actual_Subtype (Id)) |
| then |
| null; |
| |
| -- A renaming of an unchecked union has no actual subtype |
| |
| elsif Is_Unchecked_Union (Typ) then |
| null; |
| |
| -- If a record is limited its size is invariant. This is the case |
| -- in particular with record types with an access discriminant |
| -- that are used in iterators. This is an optimization, but it |
| -- also prevents typing anomalies when the prefix is further |
| -- expanded. |
| |
| -- Note that we cannot just use the Is_Limited_Record flag because |
| -- it does not apply to records with limited components, for which |
| -- this syntactic flag is not set, but whose size is also fixed. |
| |
| -- Note also that we need to build the constrained subtype for an |
| -- array in order to make the bounds explicit in most cases, but |
| -- not if the object comes from an extended return statement, as |
| -- this would create dangling references to them later on. |
| |
| elsif Is_Limited_Type (Typ) |
| and then (not Is_Array_Type (Typ) or else Is_Return_Object (Id)) |
| then |
| null; |
| |
| else |
| Subt := Make_Temporary (Loc, 'T'); |
| Remove_Side_Effects (Nam); |
| Insert_Action (N, |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Subt, |
| Subtype_Indication => |
| Make_Subtype_From_Expr (Nam, Typ))); |
| Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); |
| Set_Etype (Nam, Subt); |
| |
| -- Suppress discriminant checks on this subtype if the original |
| -- type has defaulted discriminants and Id is a "for of" loop |
| -- iterator. |
| |
| if Has_Defaulted_Discriminants (Typ) |
| and then Nkind (Original_Node (Parent (N))) = N_Loop_Statement |
| then |
| Loop_Scheme := Iteration_Scheme (Original_Node (Parent (N))); |
| |
| if Present (Loop_Scheme) |
| and then Present (Iterator_Specification (Loop_Scheme)) |
| and then |
| Defining_Identifier |
| (Iterator_Specification (Loop_Scheme)) = Id |
| then |
| Set_Checks_May_Be_Suppressed (Subt); |
| Push_Local_Suppress_Stack_Entry |
| (Entity => Subt, |
| Check => Discriminant_Check, |
| Suppress => True); |
| end if; |
| end if; |
| |
| -- Freeze subtype at once, to prevent order of elaboration |
| -- issues in the backend. The renamed object exists, so its |
| -- type is already frozen in any case. |
| |
| Freeze_Before (N, Subt); |
| end if; |
| end if; |
| end Check_Constrained_Object; |
| |
| --------------------- |
| -- Get_Object_Name -- |
| --------------------- |
| |
| function Get_Object_Name (Nod : Node_Id) return Node_Id is |
| Obj_Nam : Node_Id; |
| |
| begin |
| Obj_Nam := Nod; |
| while Present (Obj_Nam) loop |
| case Nkind (Obj_Nam) is |
| when N_Attribute_Reference |
| | N_Explicit_Dereference |
| | N_Indexed_Component |
| | N_Slice |
| => |
| Obj_Nam := Prefix (Obj_Nam); |
| |
| when N_Selected_Component => |
| Obj_Nam := Selector_Name (Obj_Nam); |
| |
| when N_Qualified_Expression | N_Type_Conversion => |
| Obj_Nam := Expression (Obj_Nam); |
| |
| when others => |
| exit; |
| end case; |
| end loop; |
| |
| return Obj_Nam; |
| end Get_Object_Name; |
| |
| -- Start of processing for Analyze_Object_Renaming |
| |
| begin |
| if Nam = Error then |
| return; |
| end if; |
| |
| Set_Is_Pure (Id, Is_Pure (Current_Scope)); |
| Enter_Name (Id); |
| |
| -- The renaming of a component that depends on a discriminant requires |
| -- an actual subtype, because in subsequent use of the object Gigi will |
| -- be unable to locate the actual bounds. This explicit step is required |
| -- when the renaming is generated in removing side effects of an |
| -- already-analyzed expression. |
| |
| if Nkind (Nam) = N_Selected_Component and then Analyzed (Nam) then |
| |
| -- The object renaming declaration may become Ghost if it renames a |
| -- Ghost entity. |
| |
| if Is_Entity_Name (Nam) then |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| end if; |
| |
| T := Etype (Nam); |
| Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam); |
| |
| if Present (Dec) then |
| Insert_Action (N, Dec); |
| T := Defining_Identifier (Dec); |
| Set_Etype (Nam, T); |
| end if; |
| elsif Present (Subtype_Mark (N)) |
| or else No (Access_Definition (N)) |
| then |
| if Present (Subtype_Mark (N)) then |
| Find_Type (Subtype_Mark (N)); |
| T := Entity (Subtype_Mark (N)); |
| Analyze (Nam); |
| |
| -- AI12-0275: Case of object renaming without a subtype_mark |
| |
| else |
| Analyze (Nam); |
| |
| -- Normal case of no overloading in object name |
| |
| if not Is_Overloaded (Nam) then |
| |
| -- Catch error cases (such as attempting to rename a procedure |
| -- or package) using the shorthand form. |
| |
| if No (Etype (Nam)) |
| or else Etype (Nam) = Standard_Void_Type |
| then |
| Error_Msg_N |
| ("object name or value expected in renaming", Nam); |
| |
| Mutate_Ekind (Id, E_Variable); |
| Set_Etype (Id, Any_Type); |
| |
| return; |
| |
| else |
| T := Etype (Nam); |
| end if; |
| |
| -- Case of overloaded name, which will be illegal if there's more |
| -- than one acceptable interpretation (such as overloaded function |
| -- calls). |
| |
| else |
| declare |
| I : Interp_Index; |
| I1 : Interp_Index; |
| It : Interp; |
| It1 : Interp; |
| Nam1 : Entity_Id; |
| |
| begin |
| -- More than one candidate interpretation is available |
| |
| -- Remove procedure calls, which syntactically cannot appear |
| -- in this context, but which cannot be removed by type |
| -- checking, because the context does not impose a type. |
| |
| Get_First_Interp (Nam, I, It); |
| while Present (It.Typ) loop |
| if It.Typ = Standard_Void_Type then |
| Remove_Interp (I); |
| end if; |
| |
| Get_Next_Interp (I, It); |
| end loop; |
| |
| Get_First_Interp (Nam, I, It); |
| I1 := I; |
| It1 := It; |
| |
| -- If there's no type present, we have an error case (such |
| -- as overloaded procedures named in the object renaming). |
| |
| if No (It.Typ) then |
| Error_Msg_N |
| ("object name or value expected in renaming", Nam); |
| |
| Mutate_Ekind (Id, E_Variable); |
| Set_Etype (Id, Any_Type); |
| |
| return; |
| end if; |
| |
| Get_Next_Interp (I, It); |
| |
| if Present (It.Typ) then |
| Nam1 := It1.Nam; |
| It1 := Disambiguate (Nam, I1, I, Any_Type); |
| |
| if It1 = No_Interp then |
| Error_Msg_N ("ambiguous name in object renaming", Nam); |
| |
| Error_Msg_Sloc := Sloc (It.Nam); |
| Error_Msg_N ("\\possible interpretation#!", Nam); |
| |
| Error_Msg_Sloc := Sloc (Nam1); |
| Error_Msg_N ("\\possible interpretation#!", Nam); |
| |
| return; |
| end if; |
| end if; |
| |
| Set_Etype (Nam, It1.Typ); |
| T := It1.Typ; |
| end; |
| end if; |
| |
| if Etype (Nam) = Standard_Exception_Type then |
| Error_Msg_N |
| ("exception requires a subtype mark in renaming", Nam); |
| return; |
| end if; |
| end if; |
| |
| -- The object renaming declaration may become Ghost if it renames a |
| -- Ghost entity. |
| |
| if Is_Entity_Name (Nam) then |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| end if; |
| |
| -- Check against AI12-0401 here before Resolve may rewrite Nam and |
| -- potentially generate spurious warnings. |
| |
| -- In the case where the object_name is a qualified_expression with |
| -- a nominal subtype T and whose expression is a name that denotes |
| -- an object Q: |
| -- * if T is an elementary subtype, then: |
| -- * Q shall be a constant other than a dereference of an access |
| -- type; or |
| -- * the nominal subtype of Q shall be statically compatible with |
| -- T; or |
| -- * T shall statically match the base subtype of its type if |
| -- scalar, or the first subtype of its type if an access type. |
| -- * if T is a composite subtype, then Q shall be known to be |
| -- constrained or T shall statically match the first subtype of |
| -- its type. |
| |
| if Nkind (Nam) = N_Qualified_Expression |
| and then Is_Object_Reference (Expression (Nam)) |
| then |
| Q := Expression (Nam); |
| |
| if (Is_Elementary_Type (T) |
| and then |
| not ((not Is_Variable (Q) |
| and then Nkind (Q) /= N_Explicit_Dereference) |
| or else Subtypes_Statically_Compatible (Etype (Q), T) |
| or else (Is_Scalar_Type (T) |
| and then Subtypes_Statically_Match |
| (T, Base_Type (T))) |
| or else (Is_Access_Type (T) |
| and then Subtypes_Statically_Match |
| (T, First_Subtype (T))))) |
| or else (Is_Composite_Type (T) |
| and then |
| |
| -- If Q is an aggregate, Is_Constrained may not be set |
| -- yet and its type may not be resolved yet. |
| -- This doesn't quite correspond to the complex notion |
| -- of "known to be constrained" but this is good enough |
| -- for a rule which is in any case too complex. |
| |
| not (Is_Constrained (Etype (Q)) |
| or else Nkind (Q) = N_Aggregate |
| or else Subtypes_Statically_Match |
| (T, First_Subtype (T)))) |
| then |
| Error_Msg_N |
| ("subtype of renamed qualified expression does not " & |
| "statically match", N); |
| return; |
| end if; |
| end if; |
| |
| Resolve (Nam, T); |
| |
| -- If the renamed object is a function call of a limited type, |
| -- the expansion of the renaming is complicated by the presence |
| -- of various temporaries and subtypes that capture constraints |
| -- of the renamed object. Rewrite node as an object declaration, |
| -- whose expansion is simpler. Given that the object is limited |
| -- there is no copy involved and no performance hit. |
| |
| if Nkind (Nam) = N_Function_Call |
| and then Is_Limited_View (Etype (Nam)) |
| and then not Is_Constrained (Etype (Nam)) |
| and then Comes_From_Source (N) |
| then |
| Set_Etype (Id, T); |
| Mutate_Ekind (Id, E_Constant); |
| Rewrite (N, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Id, |
| Constant_Present => True, |
| Object_Definition => New_Occurrence_Of (Etype (Nam), Loc), |
| Expression => Relocate_Node (Nam))); |
| return; |
| end if; |
| |
| -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object |
| -- when renaming declaration has a named access type. The Ada 2012 |
| -- coverage rules allow an anonymous access type in the context of |
| -- an expected named general access type, but the renaming rules |
| -- require the types to be the same. (An exception is when the type |
| -- of the renaming is also an anonymous access type, which can only |
| -- happen due to a renaming created by the expander.) |
| |
| if Nkind (Nam) = N_Type_Conversion |
| and then not Comes_From_Source (Nam) |
| and then Is_Anonymous_Access_Type (Etype (Expression (Nam))) |
| and then not Is_Anonymous_Access_Type (T) |
| then |
| Error_Msg_NE |
| ("cannot rename anonymous access object " |
| & "as a named access type", Expression (Nam), T); |
| end if; |
| |
| -- Check that a class-wide object is not being renamed as an object |
| -- of a specific type. The test for access types is needed to exclude |
| -- cases where the renamed object is a dynamically tagged access |
| -- result, such as occurs in certain expansions. |
| |
| if Is_Tagged_Type (T) then |
| Check_Dynamically_Tagged_Expression |
| (Expr => Nam, |
| Typ => T, |
| Related_Nod => N); |
| end if; |
| |
| -- Ada 2005 (AI-230/AI-254): Access renaming |
| |
| else pragma Assert (Present (Access_Definition (N))); |
| T := |
| Access_Definition |
| (Related_Nod => N, |
| N => Access_Definition (N)); |
| |
| Analyze (Nam); |
| |
| -- The object renaming declaration may become Ghost if it renames a |
| -- Ghost entity. |
| |
| if Is_Entity_Name (Nam) then |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| end if; |
| |
| -- Ada 2005 AI05-105: if the declaration has an anonymous access |
| -- type, the renamed object must also have an anonymous type, and |
| -- this is a name resolution rule. This was implicit in the last part |
| -- of the first sentence in 8.5.1(3/2), and is made explicit by this |
| -- recent AI. |
| |
| if not Is_Overloaded (Nam) then |
| if Ekind (Etype (Nam)) /= Ekind (T) then |
| Error_Msg_N |
| ("expect anonymous access type in object renaming", N); |
| end if; |
| |
| else |
| declare |
| I : Interp_Index; |
| It : Interp; |
| Typ : Entity_Id := Empty; |
| Seen : Boolean := False; |
| |
| begin |
| Get_First_Interp (Nam, I, It); |
| while Present (It.Typ) loop |
| |
| -- Renaming is ambiguous if more than one candidate |
| -- interpretation is type-conformant with the context. |
| |
| if Ekind (It.Typ) = Ekind (T) then |
| if Ekind (T) = E_Anonymous_Access_Subprogram_Type |
| and then |
| Type_Conformant |
| (Designated_Type (T), Designated_Type (It.Typ)) |
| then |
| if not Seen then |
| Seen := True; |
| else |
| Error_Msg_N |
| ("ambiguous expression in renaming", Nam); |
| end if; |
| |
| elsif Ekind (T) = E_Anonymous_Access_Type |
| and then |
| Covers (Designated_Type (T), Designated_Type (It.Typ)) |
| then |
| if not Seen then |
| Seen := True; |
| else |
| Error_Msg_N |
| ("ambiguous expression in renaming", Nam); |
| end if; |
| end if; |
| |
| if Covers (T, It.Typ) then |
| Typ := It.Typ; |
| Set_Etype (Nam, Typ); |
| Set_Is_Overloaded (Nam, False); |
| end if; |
| end if; |
| |
| Get_Next_Interp (I, It); |
| end loop; |
| end; |
| end if; |
| |
| Resolve (Nam, T); |
| |
| -- Do not perform the legality checks below when the resolution of |
| -- the renaming name failed because the associated type is Any_Type. |
| |
| if Etype (Nam) = Any_Type then |
| null; |
| |
| -- Ada 2005 (AI-231): In the case where the type is defined by an |
| -- access_definition, the renamed entity shall be of an access-to- |
| -- constant type if and only if the access_definition defines an |
| -- access-to-constant type. ARM 8.5.1(4) |
| |
| elsif Constant_Present (Access_Definition (N)) |
| and then not Is_Access_Constant (Etype (Nam)) |
| then |
| Error_Msg_N |
| ("(Ada 2005): the renamed object is not access-to-constant " |
| & "(RM 8.5.1(6))", N); |
| |
| elsif not Constant_Present (Access_Definition (N)) |
| and then Is_Access_Constant (Etype (Nam)) |
| then |
| Error_Msg_N |
| ("(Ada 2005): the renamed object is not access-to-variable " |
| & "(RM 8.5.1(6))", N); |
| end if; |
| |
| if Is_Access_Subprogram_Type (Etype (Nam)) then |
| Check_Subtype_Conformant |
| (Designated_Type (T), Designated_Type (Etype (Nam))); |
| |
| elsif not Subtypes_Statically_Match |
| (Designated_Type (T), |
| Available_View (Designated_Type (Etype (Nam)))) |
| then |
| Error_Msg_N |
| ("subtype of renamed object does not statically match", N); |
| end if; |
| end if; |
| |
| -- Special processing for renaming function return object. Some errors |
| -- and warnings are produced only for calls that come from source. |
| |
| if Nkind (Nam) = N_Function_Call then |
| case Ada_Version is |
| |
| -- Usage is illegal in Ada 83, but renamings are also introduced |
| -- during expansion, and error does not apply to those. |
| |
| when Ada_83 => |
| if Comes_From_Source (N) then |
| Error_Msg_N |
| ("(Ada 83) cannot rename function return object", Nam); |
| end if; |
| |
| -- In Ada 95, warn for odd case of renaming parameterless function |
| -- call if this is not a limited type (where this is useful). |
| |
| when others => |
| if Warn_On_Object_Renames_Function |
| and then No (Parameter_Associations (Nam)) |
| and then not Is_Limited_Type (Etype (Nam)) |
| and then Comes_From_Source (Nam) |
| then |
| Error_Msg_N |
| ("renaming function result object is suspicious?.r?", Nam); |
| Error_Msg_NE |
| ("\function & will be called only once?.r?", Nam, |
| Entity (Name (Nam))); |
| Error_Msg_N -- CODEFIX |
| ("\suggest using an initialized constant object " |
| & "instead?.r?", Nam); |
| end if; |
| end case; |
| end if; |
| |
| Check_Constrained_Object; |
| |
| -- An object renaming requires an exact match of the type. Class-wide |
| -- matching is not allowed. |
| |
| if Is_Class_Wide_Type (T) |
| and then Base_Type (Etype (Nam)) /= Base_Type (T) |
| then |
| Wrong_Type (Nam, T); |
| end if; |
| |
| -- We must search for an actual subtype here so that the bounds of |
| -- objects of unconstrained types don't get dropped on the floor - such |
| -- as with renamings of formal parameters. |
| |
| T2 := Get_Actual_Subtype_If_Available (Nam); |
| |
| -- Ada 2005 (AI-326): Handle wrong use of incomplete type |
| |
| if Nkind (Nam) = N_Explicit_Dereference |
| and then Ekind (Etype (T2)) = E_Incomplete_Type |
| then |
| Error_Msg_NE ("invalid use of incomplete type&", Id, T2); |
| return; |
| |
| elsif Ekind (Etype (T)) = E_Incomplete_Type then |
| Error_Msg_NE ("invalid use of incomplete type&", Id, T); |
| return; |
| end if; |
| |
| if Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then |
| declare |
| Nam_Ent : constant Entity_Id := Entity (Get_Object_Name (Nam)); |
| Nam_Decl : constant Node_Id := Declaration_Node (Nam_Ent); |
| |
| begin |
| if Has_Null_Exclusion (N) |
| and then not Has_Null_Exclusion (Nam_Decl) |
| then |
| -- Ada 2005 (AI-423): If the object name denotes a generic |
| -- formal object of a generic unit G, and the object renaming |
| -- declaration occurs within the body of G or within the body |
| -- of a generic unit declared within the declarative region |
| -- of G, then the declaration of the formal object of G must |
| -- have a null exclusion or a null-excluding subtype. |
| |
| if Is_Formal_Object (Nam_Ent) |
| and then In_Generic_Scope (Id) |
| then |
| if not Can_Never_Be_Null (Etype (Nam_Ent)) then |
| Error_Msg_N |
| ("object does not exclude `NULL` " |
| & "(RM 8.5.1(4.6/2))", N); |
| |
| elsif In_Package_Body (Scope (Id)) then |
| Error_Msg_N |
| ("formal object does not have a null exclusion" |
| & "(RM 8.5.1(4.6/2))", N); |
| end if; |
| |
| -- Ada 2005 (AI-423): Otherwise, the subtype of the object name |
| -- shall exclude null. |
| |
| elsif not Can_Never_Be_Null (Etype (Nam_Ent)) then |
| Error_Msg_N |
| ("object does not exclude `NULL` " |
| & "(RM 8.5.1(4.6/2))", N); |
| |
| -- An instance is illegal if it contains a renaming that |
| -- excludes null, and the actual does not. The renaming |
| -- declaration has already indicated that the declaration |
| -- of the renamed actual in the instance will raise |
| -- constraint_error. |
| |
| elsif Nkind (Nam_Decl) = N_Object_Declaration |
| and then In_Instance |
| and then |
| Present (Corresponding_Generic_Association (Nam_Decl)) |
| and then Nkind (Expression (Nam_Decl)) = |
| N_Raise_Constraint_Error |
| then |
| Error_Msg_N |
| ("actual does not exclude `NULL` (RM 8.5.1(4.6/2))", N); |
| |
| -- Finally, if there is a null exclusion, the subtype mark |
| -- must not be null-excluding. |
| |
| elsif No (Access_Definition (N)) |
| and then Can_Never_Be_Null (T) |
| then |
| Error_Msg_NE |
| ("`NOT NULL` not allowed (& already excludes null)", |
| N, T); |
| |
| end if; |
| |
| elsif Can_Never_Be_Null (T) |
| and then not Can_Never_Be_Null (Etype (Nam_Ent)) |
| then |
| Error_Msg_N |
| ("object does not exclude `NULL` (RM 8.5.1(4.6/2))", N); |
| |
| elsif Has_Null_Exclusion (N) |
| and then No (Access_Definition (N)) |
| and then Can_Never_Be_Null (T) |
| then |
| Error_Msg_NE |
| ("`NOT NULL` not allowed (& already excludes null)", N, T); |
| end if; |
| end; |
| end if; |
| |
| -- Set the Ekind of the entity, unless it has been set already, as is |
| -- the case for the iteration object over a container with no variable |
| -- indexing. In that case it's been marked as a constant, and we do not |
| -- want to change it to a variable. |
| |
| if Ekind (Id) /= E_Constant then |
| Mutate_Ekind (Id, E_Variable); |
| end if; |
| |
| Reinit_Object_Size_Align (Id); |
| |
| -- If N comes from source then check that the original node is an |
| -- object reference since there may have been several rewritting and |
| -- folding. Do not do this for N_Function_Call or N_Explicit_Dereference |
| -- which might correspond to rewrites of e.g. N_Selected_Component |
| -- (for example Object.Method rewriting). |
| -- If N does not come from source then assume the tree is properly |
| -- formed and accept any object reference. In such cases we do support |
| -- more cases of renamings anyway, so the actual check on which renaming |
| -- is valid is better left to the code generator as a last sanity |
| -- check. |
| |
| if Comes_From_Source (N) then |
| if Nkind (Nam) in N_Function_Call | N_Explicit_Dereference then |
| Is_Object_Ref := Is_Object_Reference (Nam); |
| else |
| Is_Object_Ref := Is_Object_Reference (Original_Node (Nam)); |
| end if; |
| else |
| Is_Object_Ref := True; |
| end if; |
| |
| if T = Any_Type or else Etype (Nam) = Any_Type then |
| return; |
| |
| -- Verify that the renamed entity is an object or function call |
| |
| elsif Is_Object_Ref then |
| if Comes_From_Source (N) then |
| if Is_Dependent_Component_Of_Mutable_Object (Nam) then |
| Error_Msg_N |
| ("illegal renaming of discriminant-dependent component", Nam); |
| end if; |
| |
| -- If the renaming comes from source and the renamed object is a |
| -- dereference, then mark the prefix as needing debug information, |
| -- since it might have been rewritten hence internally generated |
| -- and Debug_Renaming_Declaration will link the renaming to it. |
| |
| if Nkind (Nam) = N_Explicit_Dereference |
| and then Is_Entity_Name (Prefix (Nam)) |
| then |
| Set_Debug_Info_Needed (Entity (Prefix (Nam))); |
| end if; |
| end if; |
| |
| -- Weird but legal, equivalent to renaming a function call. Illegal |
| -- if the literal is the result of constant-folding an attribute |
| -- reference that is not a function. |
| |
| elsif Is_Entity_Name (Nam) |
| and then Ekind (Entity (Nam)) = E_Enumeration_Literal |
| and then Nkind (Original_Node (Nam)) /= N_Attribute_Reference |
| then |
| null; |
| |
| -- A named number can only be renamed without a subtype mark |
| |
| elsif Nkind (Nam) in N_Real_Literal | N_Integer_Literal |
| and then Present (Subtype_Mark (N)) |
| and then Present (Original_Entity (Nam)) |
| then |
| Error_Msg_N ("incompatible types in renaming", Nam); |
| |
| -- AI12-0383: Names that denote values can be renamed. |
| -- Ignore (accept) N_Raise_xxx_Error nodes in this context. |
| |
| elsif No_Raise_xxx_Error (Nam) = OK then |
| Error_Msg_Ada_2022_Feature ("value in renaming", Sloc (Nam)); |
| end if; |
| |
| Set_Etype (Id, T2); |
| |
| if not Is_Variable (Nam) then |
| Mutate_Ekind (Id, E_Constant); |
| Set_Never_Set_In_Source (Id, True); |
| Set_Is_True_Constant (Id, True); |
| end if; |
| |
| -- The entity of the renaming declaration needs to reflect whether the |
| -- renamed object is atomic, independent, volatile or VFA. These flags |
| -- are set on the renamed object in the RM legality sense. |
| |
| Set_Is_Atomic (Id, Is_Atomic_Object (Nam)); |
| Set_Is_Independent (Id, Is_Independent_Object (Nam)); |
| Set_Is_Volatile (Id, Is_Volatile_Object_Ref (Nam)); |
| Set_Is_Volatile_Full_Access |
| (Id, Is_Volatile_Full_Access_Object_Ref (Nam)); |
| |
| -- Treat as volatile if we just set the Volatile flag |
| |
| if Is_Volatile (Id) |
| |
| -- Or if we are renaming an entity which was marked this way |
| |
| -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ??? |
| |
| or else (Is_Entity_Name (Nam) |
| and then Treat_As_Volatile (Entity (Nam))) |
| then |
| Set_Treat_As_Volatile (Id, True); |
| end if; |
| |
| -- Now make the link to the renamed object |
| |
| Set_Renamed_Object (Id, Nam); |
| |
| -- Implementation-defined aspect specifications can appear in a renaming |
| -- declaration, but not language-defined ones. The call to procedure |
| -- Analyze_Aspect_Specifications will take care of this error check. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Id); |
| end if; |
| |
| -- Deal with dimensions |
| |
| Analyze_Dimension (N); |
| end Analyze_Object_Renaming; |
| |
| ------------------------------ |
| -- Analyze_Package_Renaming -- |
| ------------------------------ |
| |
| procedure Analyze_Package_Renaming (N : Node_Id) is |
| New_P : constant Entity_Id := Defining_Entity (N); |
| Old_P : Entity_Id; |
| Spec : Node_Id; |
| |
| begin |
| if Name (N) = Error then |
| return; |
| end if; |
| |
| -- Check for Text_IO special units (we may be renaming a Text_IO child), |
| -- but make sure not to catch renamings generated for package instances |
| -- that have nothing to do with them but are nevertheless homonyms. |
| |
| if Is_Entity_Name (Name (N)) |
| and then Present (Entity (Name (N))) |
| and then Is_Generic_Instance (Entity (Name (N))) |
| then |
| null; |
| else |
| Check_Text_IO_Special_Unit (Name (N)); |
| end if; |
| |
| if Current_Scope /= Standard_Standard then |
| Set_Is_Pure (New_P, Is_Pure (Current_Scope)); |
| end if; |
| |
| Enter_Name (New_P); |
| Analyze (Name (N)); |
| |
| if Is_Entity_Name (Name (N)) then |
| Old_P := Entity (Name (N)); |
| else |
| Old_P := Any_Id; |
| end if; |
| |
| if Etype (Old_P) = Any_Type then |
| Error_Msg_N ("expect package name in renaming", Name (N)); |
| |
| elsif Ekind (Old_P) /= E_Package |
| and then not (Ekind (Old_P) = E_Generic_Package |
| and then In_Open_Scopes (Old_P)) |
| then |
| if Ekind (Old_P) = E_Generic_Package then |
| Error_Msg_N |
| ("generic package cannot be renamed as a package", Name (N)); |
| else |
| Error_Msg_Sloc := Sloc (Old_P); |
| Error_Msg_NE |
| ("expect package name in renaming, found& declared#", |
| Name (N), Old_P); |
| end if; |
| |
| -- Set basic attributes to minimize cascaded errors |
| |
| Mutate_Ekind (New_P, E_Package); |
| Set_Etype (New_P, Standard_Void_Type); |
| |
| elsif Present (Renamed_Entity (Old_P)) |
| and then (From_Limited_With (Renamed_Entity (Old_P)) |
| or else Has_Limited_View (Renamed_Entity (Old_P))) |
| and then not |
| Unit_Is_Visible (Cunit (Get_Source_Unit (Renamed_Entity (Old_P)))) |
| then |
| Error_Msg_NE |
| ("renaming of limited view of package & not usable in this context" |
| & " (RM 8.5.3(3.1/2))", Name (N), Renamed_Entity (Old_P)); |
| |
| -- Set basic attributes to minimize cascaded errors |
| |
| Mutate_Ekind (New_P, E_Package); |
| Set_Etype (New_P, Standard_Void_Type); |
| |
| -- Here for OK package renaming |
| |
| else |
| -- Entities in the old package are accessible through the renaming |
| -- entity. The simplest implementation is to have both packages share |
| -- the entity list. |
| |
| Mutate_Ekind (New_P, E_Package); |
| Set_Etype (New_P, Standard_Void_Type); |
| |
| if Present (Renamed_Entity (Old_P)) then |
| Set_Renamed_Entity (New_P, Renamed_Entity (Old_P)); |
| else |
| Set_Renamed_Entity (New_P, Old_P); |
| end if; |
| |
| -- The package renaming declaration may become Ghost if it renames a |
| -- Ghost entity. |
| |
| Mark_Ghost_Renaming (N, Old_P); |
| |
| Set_Has_Completion (New_P); |
| Set_First_Entity (New_P, First_Entity (Old_P)); |
| Set_Last_Entity (New_P, Last_Entity (Old_P)); |
| Set_First_Private_Entity (New_P, First_Private_Entity (Old_P)); |
| Check_Library_Unit_Renaming (N, Old_P); |
| Generate_Reference (Old_P, Name (N)); |
| |
| -- If the renaming is in the visible part of a package, then we set |
| -- Renamed_In_Spec for the renamed package, to prevent giving |
| -- warnings about no entities referenced. Such a warning would be |
| -- overenthusiastic, since clients can see entities in the renamed |
| -- package via the visible package renaming. |
| |
| declare |
| Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); |
| begin |
| if Ekind (Ent) = E_Package |
| and then not In_Private_Part (Ent) |
| and then In_Extended_Main_Source_Unit (N) |
| and then Ekind (Old_P) = E_Package |
| then |
| Set_Renamed_In_Spec (Old_P); |
| end if; |
| end; |
| |
| -- If this is the renaming declaration of a package instantiation |
| -- within itself, it is the declaration that ends the list of actuals |
| -- for the instantiation. At this point, the subtypes that rename |
| -- the actuals are flagged as generic, to avoid spurious ambiguities |
| -- if the actuals for two distinct formals happen to coincide. If |
| -- the actual is a private type, the subtype has a private completion |
| -- that is flagged in the same fashion. |
| |
| -- Resolution is identical to what is was in the original generic. |
| -- On exit from the generic instance, these are turned into regular |
| -- subtypes again, so they are compatible with types in their class. |
| |
| if not Is_Generic_Instance (Old_P) then |
| return; |
| else |
| Spec := Specification (Unit_Declaration_Node (Old_P)); |
| end if; |
| |
| if Nkind (Spec) = N_Package_Specification |
| and then Present (Generic_Parent (Spec)) |
| and then Old_P = Current_Scope |
| and then Chars (New_P) = Chars (Generic_Parent (Spec)) |
| then |
| declare |
| E : Entity_Id; |
| |
| begin |
| E := First_Entity (Old_P); |
| while Present (E) and then E /= New_P loop |
| if Is_Type (E) |
| and then Nkind (Parent (E)) = N_Subtype_Declaration |
| then |
| Set_Is_Generic_Actual_Type (E); |
| |
| if Is_Private_Type (E) |
| and then Present (Full_View (E)) |
| then |
| Set_Is_Generic_Actual_Type (Full_View (E)); |
| end if; |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end; |
| end if; |
| end if; |
| |
| -- Implementation-defined aspect specifications can appear in a renaming |
| -- declaration, but not language-defined ones. The call to procedure |
| -- Analyze_Aspect_Specifications will take care of this error check. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, New_P); |
| end if; |
| end Analyze_Package_Renaming; |
| |
| ------------------------------- |
| -- Analyze_Renamed_Character -- |
| ------------------------------- |
| |
| procedure Analyze_Renamed_Character |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean) |
| is |
| C : constant Node_Id := Name (N); |
| |
| begin |
| if Ekind (New_S) = E_Function then |
| Resolve (C, Etype (New_S)); |
| |
| if Is_Body then |
| Check_Frozen_Renaming (N, New_S); |
| end if; |
| |
| else |
| Error_Msg_N ("character literal can only be renamed as function", N); |
| end if; |
| end Analyze_Renamed_Character; |
| |
| --------------------------------- |
| -- Analyze_Renamed_Dereference -- |
| --------------------------------- |
| |
| procedure Analyze_Renamed_Dereference |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean) |
| is |
| Nam : constant Node_Id := Name (N); |
| P : constant Node_Id := Prefix (Nam); |
| Typ : Entity_Id; |
| Ind : Interp_Index; |
| It : Interp; |
| |
| begin |
| if not Is_Overloaded (P) then |
| if Ekind (Etype (Nam)) /= E_Subprogram_Type |
| or else not Type_Conformant (Etype (Nam), New_S) |
| then |
| Error_Msg_N ("designated type does not match specification", P); |
| else |
| Resolve (P); |
| end if; |
| |
| return; |
| |
| else |
| Typ := Any_Type; |
| Get_First_Interp (Nam, Ind, It); |
| |
| while Present (It.Nam) loop |
| |
| if Ekind (It.Nam) = E_Subprogram_Type |
| and then Type_Conformant (It.Nam, New_S) |
| then |
| if Typ /= Any_Id then |
| Error_Msg_N ("ambiguous renaming", P); |
| return; |
| else |
| Typ := It.Nam; |
| end if; |
| end if; |
| |
| Get_Next_Interp (Ind, It); |
| end loop; |
| |
| if Typ = Any_Type then |
| Error_Msg_N ("designated type does not match specification", P); |
| else |
| Resolve (N, Typ); |
| |
| if Is_Body then |
| Check_Frozen_Renaming (N, New_S); |
| end if; |
| end if; |
| end if; |
| end Analyze_Renamed_Dereference; |
| |
| --------------------------- |
| -- Analyze_Renamed_Entry -- |
| --------------------------- |
| |
| procedure Analyze_Renamed_Entry |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean) |
| is |
| Nam : constant Node_Id := Name (N); |
| Sel : constant Node_Id := Selector_Name (Nam); |
| Is_Actual : constant Boolean := Present (Corresponding_Formal_Spec (N)); |
| Old_S : Entity_Id; |
| |
| begin |
| if Entity (Sel) = Any_Id then |
| |
| -- Selector is undefined on prefix. Error emitted already |
| |
| Set_Has_Completion (New_S); |
| return; |
| end if; |
| |
| -- Otherwise find renamed entity and build body of New_S as a call to it |
| |
| Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S); |
| |
| if Old_S = Any_Id then |
| Error_Msg_N ("no subprogram or entry matches specification", N); |
| else |
| if Is_Body then |
| Check_Subtype_Conformant (New_S, Old_S, N); |
| Generate_Reference (New_S, Defining_Entity (N), 'b'); |
| Style.Check_Identifier (Defining_Entity (N), New_S); |
| |
| else |
| -- Only mode conformance required for a renaming_as_declaration |
| |
| Check_Mode_Conformant (New_S, Old_S, N); |
| end if; |
| |
| Inherit_Renamed_Profile (New_S, Old_S); |
| |
| -- The prefix can be an arbitrary expression that yields a task or |
| -- protected object, so it must be resolved. |
| |
| if Is_Access_Type (Etype (Prefix (Nam))) then |
| Insert_Explicit_Dereference (Prefix (Nam)); |
| end if; |
| Resolve (Prefix (Nam), Scope (Old_S)); |
| end if; |
| |
| Set_Convention (New_S, Convention (Old_S)); |
| Set_Has_Completion (New_S, Inside_A_Generic); |
| |
| -- AI05-0225: If the renamed entity is a procedure or entry of a |
| -- protected object, the target object must be a variable. |
| |
| if Is_Protected_Type (Scope (Old_S)) |
| and then Ekind (New_S) = E_Procedure |
| and then not Is_Variable (Prefix (Nam)) |
| then |
| if Is_Actual then |
| Error_Msg_N |
| ("target object of protected operation used as actual for " |
| & "formal procedure must be a variable", Nam); |
| else |
| Error_Msg_N |
| ("target object of protected operation renamed as procedure, " |
| & "must be a variable", Nam); |
| end if; |
| end if; |
| |
| if Is_Body then |
| Check_Frozen_Renaming (N, New_S); |
| end if; |
| end Analyze_Renamed_Entry; |
| |
| ----------------------------------- |
| -- Analyze_Renamed_Family_Member -- |
| ----------------------------------- |
| |
| procedure Analyze_Renamed_Family_Member |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean) |
| is |
| Nam : constant Node_Id := Name (N); |
| P : constant Node_Id := Prefix (Nam); |
| Old_S : Entity_Id; |
| |
| begin |
| if (Is_Entity_Name (P) and then Ekind (Entity (P)) = E_Entry_Family) |
| or else (Nkind (P) = N_Selected_Component |
| and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family) |
| then |
| if Is_Entity_Name (P) then |
| Old_S := Entity (P); |
| else |
| Old_S := Entity (Selector_Name (P)); |
| end if; |
| |
| if not Entity_Matches_Spec (Old_S, New_S) then |
| Error_Msg_N ("entry family does not match specification", N); |
| |
| elsif Is_Body then |
| Check_Subtype_Conformant (New_S, Old_S, N); |
| Generate_Reference (New_S, Defining_Entity (N), 'b'); |
| Style.Check_Identifier (Defining_Entity (N), New_S); |
| end if; |
| |
| else |
| Error_Msg_N ("no entry family matches specification", N); |
| end if; |
| |
| Set_Has_Completion (New_S, Inside_A_Generic); |
| |
| if Is_Body then |
| Check_Frozen_Renaming (N, New_S); |
| end if; |
| end Analyze_Renamed_Family_Member; |
| |
| ----------------------------------------- |
| -- Analyze_Renamed_Primitive_Operation -- |
| ----------------------------------------- |
| |
| procedure Analyze_Renamed_Primitive_Operation |
| (N : Node_Id; |
| New_S : Entity_Id; |
| Is_Body : Boolean) |
| is |
| Old_S : Entity_Id; |
| Nam : Entity_Id; |
| |
| function Conforms |
| (Subp : Entity_Id; |
| Ctyp : Conformance_Type) return Boolean; |
| -- Verify that the signatures of the renamed entity and the new entity |
| -- match. The first formal of the renamed entity is skipped because it |
| -- is the target object in any subsequent call. |
| |
| -------------- |
| -- Conforms -- |
| -------------- |
| |
| function Conforms |
| (Subp : Entity_Id; |
| Ctyp : Conformance_Type) return Boolean |
| is |
| Old_F : Entity_Id; |
| New_F : Entity_Id; |
| |
| begin |
| if Ekind (Subp) /= Ekind (New_S) then |
| return False; |
| end if; |
| |
| Old_F := Next_Formal (First_Formal (Subp)); |
| New_F := First_Formal (New_S); |
| while Present (Old_F) and then Present (New_F) loop |
| if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then |
| return False; |
| end if; |
| |
| if Ctyp >= Mode_Conformant |
| and then Ekind (Old_F) /= Ekind (New_F) |
| then |
| return False; |
| end if; |
| |
| Next_Formal (New_F); |
| Next_Formal (Old_F); |
| end loop; |
| |
| return True; |
| end Conforms; |
| |
| -- Start of processing for Analyze_Renamed_Primitive_Operation |
| |
| begin |
| if not Is_Overloaded (Selector_Name (Name (N))) then |
| Old_S := Entity (Selector_Name (Name (N))); |
| |
| if not Conforms (Old_S, Type_Conformant) then |
| Old_S := Any_Id; |
| end if; |
| |
| else |
| -- Find the operation that matches the given signature |
| |
| declare |
| It : Interp; |
| Ind : Interp_Index; |
| |
| begin |
| Old_S := Any_Id; |
| Get_First_Interp (Selector_Name (Name (N)), Ind, It); |
| |
| while Present (It.Nam) loop |
| if Conforms (It.Nam, Type_Conformant) then |
| Old_S := It.Nam; |
| end if; |
| |
| Get_Next_Interp (Ind, It); |
| end loop; |
| end; |
| end if; |
| |
| if Old_S = Any_Id then |
| Error_Msg_N ("no subprogram or entry matches specification", N); |
| |
| else |
| if Is_Body then |
| if not Conforms (Old_S, Subtype_Conformant) then |
| Error_Msg_N ("subtype conformance error in renaming", N); |
| end if; |
| |
| Generate_Reference (New_S, Defining_Entity (N), 'b'); |
| Style.Check_Identifier (Defining_Entity (N), New_S); |
| |
| else |
| -- Only mode conformance required for a renaming_as_declaration |
| |
| if not Conforms (Old_S, Mode_Conformant) then |
| Error_Msg_N ("mode conformance error in renaming", N); |
| end if; |
| |
| -- AI12-0204: The prefix of a prefixed view that is renamed or |
| -- passed as a formal subprogram must be renamable as an object. |
| |
| Nam := Prefix (Name (N)); |
| |
| if Is_Object_Reference (Nam) then |
| if Is_Dependent_Component_Of_Mutable_Object (Nam) then |
| Error_Msg_N |
| ("illegal renaming of discriminant-dependent component", |
| Nam); |
| end if; |
| else |
| Error_Msg_N ("expect object name in renaming", Nam); |
| end if; |
| |
| -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed |
| -- view of a subprogram is intrinsic, because the compiler has |
| -- to generate a wrapper for any call to it. If the name in a |
| -- subprogram renaming is a prefixed view, the entity is thus |
| -- intrinsic, and 'Access cannot be applied to it. |
| |
| Set_Convention (New_S, Convention_Intrinsic); |
| end if; |
| |
| -- Inherit_Renamed_Profile (New_S, Old_S); |
| |
| -- The prefix can be an arbitrary expression that yields an |
| -- object, so it must be resolved. |
| |
| Resolve (Prefix (Name (N))); |
| end if; |
| end Analyze_Renamed_Primitive_Operation; |
| |
| --------------------------------- |
| -- Analyze_Subprogram_Renaming -- |
| --------------------------------- |
| |
| procedure Analyze_Subprogram_Renaming (N : Node_Id) is |
| Formal_Spec : constant Entity_Id := Corresponding_Formal_Spec (N); |
| Is_Actual : constant Boolean := Present (Formal_Spec); |
| Nam : constant Node_Id := Name (N); |
| Save_AV : constant Ada_Version_Type := Ada_Version; |
| Save_AVP : constant Node_Id := Ada_Version_Pragma; |
| Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; |
| Spec : constant Node_Id := Specification (N); |
| |
| Old_S : Entity_Id := Empty; |
| Rename_Spec : Entity_Id; |
| |
| procedure Check_Null_Exclusion |
| (Ren : Entity_Id; |
| Sub : Entity_Id); |
| -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the |
| -- following AI rules: |
| -- |
| -- If Ren denotes a generic formal object of a generic unit G, and the |
| -- renaming (or instantiation containing the actual) occurs within the |
| -- body of G or within the body of a generic unit declared within the |
| -- declarative region of G, then the corresponding parameter of G |
| -- shall have a null_exclusion; Otherwise the subtype of the Sub's |
| -- formal parameter shall exclude null. |
| -- |
| -- Similarly for its return profile. |
| |
| procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id); |
| -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not |
| -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)). |
| |
| procedure Freeze_Actual_Profile; |
| -- In Ada 2012, enforce the freezing rule concerning formal incomplete |
| -- types: a callable entity freezes its profile, unless it has an |
| -- incomplete untagged formal (RM 13.14(10.2/3)). |
| |
| function Has_Class_Wide_Actual return Boolean; |
| -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if N is |
| -- the renaming for a defaulted formal subprogram where the actual for |
| -- the controlling formal type is class-wide. |
| |
| procedure Handle_Instance_With_Class_Wide_Type |
| (Inst_Node : Node_Id; |
| Ren_Id : Entity_Id; |
| Wrapped_Prim : out Entity_Id; |
| Wrap_Id : out Entity_Id); |
| -- Ada 2012 (AI05-0071), Ada 2022 (AI12-0165): when the actual type |
| -- of an instantiation is a class-wide type T'Class we may need to |
| -- wrap a primitive operation of T; this routine looks for a suitable |
| -- primitive to be wrapped and (if the wrapper is required) returns the |
| -- Id of the wrapped primitive and the Id of the built wrapper. Ren_Id |
| -- is the defining entity for the renamed subprogram specification. |
| |
| function Original_Subprogram (Subp : Entity_Id) return Entity_Id; |
| -- Find renamed entity when the declaration is a renaming_as_body and |
| -- the renamed entity may itself be a renaming_as_body. Used to enforce |
| -- rule that a renaming_as_body is illegal if the declaration occurs |
| -- before the subprogram it completes is frozen, and renaming indirectly |
| -- renames the subprogram itself.(Defect Report 8652/0027). |
| |
| -------------------------- |
| -- Check_Null_Exclusion -- |
| -------------------------- |
| |
| procedure Check_Null_Exclusion |
| (Ren : Entity_Id; |
| Sub : Entity_Id) |
| is |
| Ren_Formal : Entity_Id; |
| Sub_Formal : Entity_Id; |
| |
| function Null_Exclusion_Mismatch |
| (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean; |
| -- Return True if there is a null exclusion mismatch between |
| -- Renaming and Renamed, False otherwise. |
| |
| ----------------------------- |
| -- Null_Exclusion_Mismatch -- |
| ----------------------------- |
| |
| function Null_Exclusion_Mismatch |
| (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean is |
| begin |
| return Has_Null_Exclusion (Parent (Renaming)) |
| and then |
| not (Has_Null_Exclusion (Parent (Renamed)) |
| or else (Can_Never_Be_Null (Etype (Renamed)) |
| and then not |
| (Is_Formal_Subprogram (Sub) |
| and then In_Generic_Body (Current_Scope)))); |
| end Null_Exclusion_Mismatch; |
| |
| begin |
| -- Parameter check |
| |
| Ren_Formal := First_Formal (Ren); |
| Sub_Formal := First_Formal (Sub); |
| while Present (Ren_Formal) and then Present (Sub_Formal) loop |
| if Null_Exclusion_Mismatch (Ren_Formal, Sub_Formal) then |
| Error_Msg_Sloc := Sloc (Sub_Formal); |
| Error_Msg_NE |
| ("`NOT NULL` required for parameter &#", |
| Ren_Formal, Sub_Formal); |
| end if; |
| |
| Next_Formal (Ren_Formal); |
| Next_Formal (Sub_Formal); |
| end loop; |
| |
| -- Return profile check |
| |
| if Nkind (Parent (Ren)) = N_Function_Specification |
| and then Nkind (Parent (Sub)) = N_Function_Specification |
| and then Null_Exclusion_Mismatch (Ren, Sub) |
| then |
| Error_Msg_Sloc := Sloc (Sub); |
| Error_Msg_N ("return must specify `NOT NULL`#", Ren); |
| end if; |
| end Check_Null_Exclusion; |
| |
| ------------------------------------- |
| -- Check_SPARK_Primitive_Operation -- |
| ------------------------------------- |
| |
| procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is |
| Prag : constant Node_Id := SPARK_Pragma (Subp_Id); |
| Typ : Entity_Id; |
| |
| begin |
| -- Nothing to do when the subprogram is not subject to SPARK_Mode On |
| -- because this check applies to SPARK code only. |
| |
| if not (Present (Prag) |
| and then Get_SPARK_Mode_From_Annotation (Prag) = On) |
| then |
| return; |
| |
| -- Nothing to do when the subprogram is not a primitive operation |
| |
| elsif not Is_Primitive (Subp_Id) then |
| return; |
| end if; |
| |
| Typ := Find_Dispatching_Type (Subp_Id); |
| |
| -- Nothing to do when the subprogram is a primitive operation of an |
| -- untagged type. |
| |
| if No (Typ) then |
| return; |
| end if; |
| |
| -- At this point a renaming declaration introduces a new primitive |
| -- operation for a tagged type. |
| |
| Error_Msg_Node_2 := Typ; |
| Error_Msg_NE |
| ("subprogram renaming & cannot declare primitive for type & " |
| & "(SPARK RM 6.1.1(3))", N, Subp_Id); |
| end Check_SPARK_Primitive_Operation; |
| |
| --------------------------- |
| -- Freeze_Actual_Profile -- |
| --------------------------- |
| |
| procedure Freeze_Actual_Profile is |
| F : Entity_Id; |
| Has_Untagged_Inc : Boolean; |
| Instantiation_Node : constant Node_Id := Parent (N); |
| |
| begin |
| if Ada_Version >= Ada_2012 then |
| F := First_Formal (Formal_Spec); |
| Has_Untagged_Inc := False; |
| while Present (F) loop |
| if Ekind (Etype (F)) = E_Incomplete_Type |
| and then not Is_Tagged_Type (Etype (F)) |
| then |
| Has_Untagged_Inc := True; |
| exit; |
| end if; |
| |
| Next_Formal (F); |
| end loop; |
| |
| if Ekind (Formal_Spec) = E_Function |
| and then not Is_Tagged_Type (Etype (Formal_Spec)) |
| then |
| Has_Untagged_Inc := True; |
| end if; |
| |
| if not Has_Untagged_Inc then |
| F := First_Formal (Old_S); |
| while Present (F) loop |
| Freeze_Before (Instantiation_Node, Etype (F)); |
| |
| if Is_Incomplete_Or_Private_Type (Etype (F)) |
| and then No (Underlying_Type (Etype (F))) |
| then |
| -- Exclude generic types, or types derived from them. |
| -- They will be frozen in the enclosing instance. |
| |
| if Is_Generic_Type (Etype (F)) |
| or else Is_Generic_Type (Root_Type (Etype (F))) |
| then |
| null; |
| |
| -- A limited view of a type declared elsewhere needs no |
| -- freezing actions. |
| |
| elsif From_Limited_With (Etype (F)) then |
| null; |
| |
| else |
| Error_Msg_NE |
| ("type& must be frozen before this point", |
| Instantiation_Node, Etype (F)); |
| end if; |
| end if; |
| |
| Next_Formal (F); |
| end loop; |
| end if; |
| end if; |
| end Freeze_Actual_Profile; |
| |
| --------------------------- |
| -- Has_Class_Wide_Actual -- |
| --------------------------- |
| |
| function Has_Class_Wide_Actual return Boolean is |
| Formal : Entity_Id; |
| Formal_Typ : Entity_Id; |
| |
| begin |
| if Is_Actual then |
| Formal := First_Formal (Formal_Spec); |
| while Present (Formal) loop |
| Formal_Typ := Etype (Formal); |
| |
| if Has_Unknown_Discriminants (Formal_Typ) |
| and then not Is_Class_Wide_Type (Formal_Typ) |
| and then Is_Class_Wide_Type (Get_Instance_Of (Formal_Typ)) |
| then |
| return True; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| end if; |
| |
| return False; |
| end Has_Class_Wide_Actual; |
| |
| ------------------------------------------ |
| -- Handle_Instance_With_Class_Wide_Type -- |
| ------------------------------------------ |
| |
| procedure Handle_Instance_With_Class_Wide_Type |
| (Inst_Node : Node_Id; |
| Ren_Id : Entity_Id; |
| Wrapped_Prim : out Entity_Id; |
| Wrap_Id : out Entity_Id) |
| is |
| procedure Build_Class_Wide_Wrapper |
| (Ren_Id : Entity_Id; |
| Prim_Op : Entity_Id; |
| Wrap_Id : out Entity_Id); |
| -- Build a wrapper for the renaming Ren_Id of subprogram Prim_Op. |
| |
| procedure Find_Suitable_Candidate |
| (Prim_Op : out Entity_Id; |
| Is_CW_Prim : out Boolean); |
| -- Look for a suitable primitive to be wrapped (Prim_Op); Is_CW_Prim |
| -- indicates that the found candidate is a class-wide primitive (to |
| -- help the caller decide if the wrapper is required). |
| |
| ------------------------------ |
| -- Build_Class_Wide_Wrapper -- |
| ------------------------------ |
| |
| procedure Build_Class_Wide_Wrapper |
| (Ren_Id : Entity_Id; |
| Prim_Op : Entity_Id; |
| Wrap_Id : out Entity_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| function Build_Call |
| (Subp_Id : Entity_Id; |
| Params : List_Id) return Node_Id; |
| -- Create a dispatching call to invoke routine Subp_Id with |
| -- actuals built from the parameter specifications of list Params. |
| |
| function Build_Expr_Fun_Call |
| (Subp_Id : Entity_Id; |
| Params : List_Id) return Node_Id; |
| -- Create a dispatching call to invoke function Subp_Id with |
| -- actuals built from the parameter specifications of list Params. |
| -- Directly return the call, so that it can be used inside an |
| -- expression function. This is a requirement of GNATprove mode. |
| |
| function Build_Spec (Subp_Id : Entity_Id) return Node_Id; |
| -- Create a subprogram specification based on the subprogram |
| -- profile of Subp_Id. |
| |
| ---------------- |
| -- Build_Call -- |
| ---------------- |
| |
| function Build_Call |
| (Subp_Id : Entity_Id; |
| Params : List_Id) return Node_Id |
| is |
| Actuals : constant List_Id := New_List; |
| Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); |
| Formal : Node_Id; |
| |
| begin |
| -- Build the actual parameters of the call |
| |
| Formal := First (Params); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, |
| Chars (Defining_Identifier (Formal)))); |
| Next (Formal); |
| end loop; |
| |
| -- Generate: |
| -- return Subp_Id (Actuals); |
| |
| if Ekind (Subp_Id) in E_Function | E_Operator then |
| return |
| Make_Simple_Return_Statement (Loc, |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Call_Ref, |
| Parameter_Associations => Actuals)); |
| |
| -- Generate: |
| -- Subp_Id (Actuals); |
| |
| else |
| return |
| Make_Procedure_Call_Statement (Loc, |
| Name => Call_Ref, |
| Parameter_Associations => Actuals); |
| end if; |
| end Build_Call; |
| |
| ------------------------- |
| -- Build_Expr_Fun_Call -- |
| ------------------------- |
| |
| function Build_Expr_Fun_Call |
| (Subp_Id : Entity_Id; |
| Params : List_Id) return Node_Id |
| is |
| Actuals : constant List_Id := New_List; |
| Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc); |
| Formal : Node_Id; |
| |
| begin |
| pragma Assert (Ekind (Subp_Id) in E_Function | E_Operator); |
| |
| -- Build the actual parameters of the call |
| |
| Formal := First (Params); |
| while Present (Formal) loop |
| Append_To (Actuals, |
| Make_Identifier (Loc, |
| Chars (Defining_Identifier (Formal)))); |
| Next (Formal); |
| end loop; |
| |
| -- Generate: |
| -- Subp_Id (Actuals); |
| |
| return |
| Make_Function_Call (Loc, |
| Name => Call_Ref, |
| Parameter_Associations => Actuals); |
| end Build_Expr_Fun_Call; |
| |
| ---------------- |
| -- Build_Spec -- |
| ---------------- |
| |
| function Build_Spec (Subp_Id : Entity_Id) return Node_Id is |
| Params : constant List_Id := Copy_Parameter_List (Subp_Id); |
| Spec_Id : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Subp_Id), 'R')); |
| |
| begin |
| if Ekind (Formal_Spec) = E_Procedure then |
| return |
| Make_Procedure_Specification (Loc, |
| Defining_Unit_Name => Spec_Id, |
| Parameter_Specifications => Params); |
| else |
| return |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Spec_Id, |
| Parameter_Specifications => Params, |
| Result_Definition => |
| New_Copy_Tree (Result_Definition (Spec))); |
| end if; |
| end Build_Spec; |
| |
| -- Local variables |
| |
| Body_Decl : Node_Id; |
| Spec_Decl : Node_Id; |
| New_Spec : Node_Id; |
| |
| -- Start of processing for Build_Class_Wide_Wrapper |
| |
| begin |
| pragma Assert (not Error_Posted (Nam)); |
| |
| -- Step 1: Create the declaration and the body of the wrapper, |
| -- insert all the pieces into the tree. |
| |
| -- In GNATprove mode, create a function wrapper in the form of an |
| -- expression function, so that an implicit postcondition relating |
| -- the result of calling the wrapper function and the result of |
| -- the dispatching call to the wrapped function is known during |
| -- proof. |
| |
| if GNATprove_Mode |
| and then Ekind (Ren_Id) in E_Function | E_Operator |
| then |
| New_Spec := Build_Spec (Ren_Id); |
| Body_Decl := |
| Make_Expression_Function (Loc, |
| Specification => New_Spec, |
| Expression => |
| Build_Expr_Fun_Call |
| (Subp_Id => Prim_Op, |
| Params => Parameter_Specifications (New_Spec))); |
| |
| Wrap_Id := Defining_Entity (Body_Decl); |
| |
| -- Otherwise, create separate spec and body for the subprogram |
| |
| else |
| Spec_Decl := |
| Make_Subprogram_Declaration (Loc, |
| Specification => Build_Spec (Ren_Id)); |
| Insert_Before_And_Analyze (N, Spec_Decl); |
| |
| Wrap_Id := Defining_Entity (Spec_Decl); |
| |
| Body_Decl := |
| Make_Subprogram_Body (Loc, |
| Specification => Build_Spec (Ren_Id), |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Build_Call |
| (Subp_Id => Prim_Op, |
| Params => |
| Parameter_Specifications |
| (Specification (Spec_Decl)))))); |
| |
| Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); |
| end if; |
| |
| Set_Is_Class_Wide_Wrapper (Wrap_Id); |
| |
| -- If the operator carries an Eliminated pragma, indicate that |
| -- the wrapper is also to be eliminated, to prevent spurious |
| -- errors when using gnatelim on programs that include box- |
| -- defaulted initialization of equality operators. |
| |
| Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op)); |
| |
| -- In GNATprove mode, insert the body in the tree for analysis |
| |
| if GNATprove_Mode then |
| Insert_Before_And_Analyze (N, Body_Decl); |
| end if; |
| |
| -- The generated body does not freeze and must be analyzed when |
| -- the class-wide wrapper is frozen. The body is only needed if |
| -- expansion is enabled. |
| |
| if Expander_Active then |
| Append_Freeze_Action (Wrap_Id, Body_Decl); |
| end if; |
| |
| -- Step 2: The subprogram renaming aliases the wrapper |
| |
| Rewrite (Name (N), New_Occurrence_Of (Wrap_Id, Loc)); |
| end Build_Class_Wide_Wrapper; |
| |
| ----------------------------- |
| -- Find_Suitable_Candidate -- |
| ----------------------------- |
| |
| procedure Find_Suitable_Candidate |
| (Prim_Op : out Entity_Id; |
| Is_CW_Prim : out Boolean) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| function Find_Primitive (Typ : Entity_Id) return Entity_Id; |
| -- Find a primitive subprogram of type Typ which matches the |
| -- profile of the renaming declaration. |
| |
| procedure Interpretation_Error (Subp_Id : Entity_Id); |
| -- Emit a continuation error message suggesting subprogram Subp_Id |
| -- as a possible interpretation. |
| |
| function Is_Intrinsic_Equality |
| (Subp_Id : Entity_Id) return Boolean; |
| -- Determine whether subprogram Subp_Id denotes the intrinsic "=" |
| -- operator. |
| |
| function Is_Suitable_Candidate |
| (Subp_Id : Entity_Id) return Boolean; |
| -- Determine whether subprogram Subp_Id is a suitable candidate |
| -- for the role of a wrapped subprogram. |
| |
| -------------------- |
| -- Find_Primitive -- |
| -------------------- |
| |
| function Find_Primitive (Typ : Entity_Id) return Entity_Id is |
| procedure Replace_Parameter_Types (Spec : Node_Id); |
| -- Given a specification Spec, replace all class-wide parameter |
| -- types with reference to type Typ. |
| |
| ----------------------------- |
| -- Replace_Parameter_Types -- |
| ----------------------------- |
| |
| procedure Replace_Parameter_Types (Spec : Node_Id) is |
| Formal : Node_Id; |
| Formal_Id : Entity_Id; |
| Formal_Typ : Node_Id; |
| |
| begin |
| Formal := First (Parameter_Specifications (Spec)); |
| while Present (Formal) loop |
| Formal_Id := Defining_Identifier (Formal); |
| Formal_Typ := Parameter_Type (Formal); |
| |
| -- Create a new entity for each class-wide formal to |
| -- prevent aliasing with the original renaming. Replace |
| -- the type of such a parameter with the candidate type. |
| |
| if Nkind (Formal_Typ) = N_Identifier |
| and then Is_Class_Wide_Type (Etype (Formal_Typ)) |
| then |
| Set_Defining_Identifier (Formal, |
| Make_Defining_Identifier (Loc, Chars (Formal_Id))); |
| |
| Set_Parameter_Type (Formal, |
| New_Occurrence_Of (Typ, Loc)); |
| end if; |
| |
| Next (Formal); |
| end loop; |
| end Replace_Parameter_Types; |
| |
| -- Local variables |
| |
| Alt_Ren : constant Node_Id := New_Copy_Tree (N); |
| Alt_Nam : constant Node_Id := Name (Alt_Ren); |
| Alt_Spec : constant Node_Id := Specification (Alt_Ren); |
| Subp_Id : Entity_Id; |
| |
| -- Start of processing for Find_Primitive |
| |
| begin |
| -- Each attempt to find a suitable primitive of a particular |
| -- type operates on its own copy of the original renaming. |
| -- As a result the original renaming is kept decoration and |
| -- side-effect free. |
| |
| -- Inherit the overloaded status of the renamed subprogram name |
| |
| if Is_Overloaded (Nam) then |
| Set_Is_Overloaded (Alt_Nam); |
| Save_Interps (Nam, Alt_Nam); |
| end if; |
| |
| -- The copied renaming is hidden from visibility to prevent the |
| -- pollution of the enclosing context. |
| |
| Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R')); |
| |
| -- The types of all class-wide parameters must be changed to |
| -- the candidate type. |
| |
| Replace_Parameter_Types (Alt_Spec); |
| |
| -- Try to find a suitable primitive that matches the altered |
| -- profile of the renaming specification. |
| |
| Subp_Id := |
| Find_Renamed_Entity |
| (N => Alt_Ren, |
| Nam => Name (Alt_Ren), |
| New_S => Analyze_Subprogram_Specification (Alt_Spec), |
| Is_Actual => Is_Actual); |
| |
| -- Do not return Any_Id if the resolution of the altered |
| -- profile failed as this complicates further checks on |
| -- the caller side; return Empty instead. |
| |
| if Subp_Id = Any_Id then |
| return Empty; |
| else |
| return Subp_Id; |
| end if; |
| end Find_Primitive; |
| |
| -------------------------- |
| -- Interpretation_Error -- |
| -------------------------- |
| |
| procedure Interpretation_Error (Subp_Id : Entity_Id) is |
| begin |
| Error_Msg_Sloc := Sloc (Subp_Id); |
| |
| if Is_Internal (Subp_Id) then |
| Error_Msg_NE |
| ("\\possible interpretation: predefined & #", |
| Spec, Formal_Spec); |
| else |
| Error_Msg_NE |
| ("\\possible interpretation: & defined #", |
| Spec, Formal_Spec); |
| end if; |
| end Interpretation_Error; |
| |
| --------------------------- |
| -- Is_Intrinsic_Equality -- |
| --------------------------- |
| |
| function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean |
| is |
| begin |
| return |
| Ekind (Subp_Id) = E_Operator |
| and then Chars (Subp_Id) = Name_Op_Eq |
| and then Is_Intrinsic_Subprogram (Subp_Id); |
| end Is_Intrinsic_Equality; |
| |
| --------------------------- |
| -- Is_Suitable_Candidate -- |
| --------------------------- |
| |
| function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean |
| is |
| begin |
| if No (Subp_Id) then |
| return False; |
| |
| -- An intrinsic subprogram is never a good candidate. This |
| -- is an indication of a missing primitive, either defined |
| -- directly or inherited from a parent tagged type. |
| |
| elsif Is_Intrinsic_Subprogram (Subp_Id) then |
| return False; |
| |
| else |
| return True; |
| end if; |
| end Is_Suitable_Candidate; |
| |
| -- Local variables |
| |
| Actual_Typ : Entity_Id := Empty; |
| -- The actual class-wide type for Formal_Typ |
| |
| CW_Prim_OK : Boolean; |
| CW_Prim_Op : Entity_Id; |
| -- The class-wide subprogram (if available) that corresponds to |
| -- the renamed generic formal subprogram. |
| |
| Formal_Typ : Entity_Id := Empty; |
| -- The generic formal type with unknown discriminants |
| |
| Root_Prim_OK : Boolean; |
| Root_Prim_Op : Entity_Id; |
| -- The root type primitive (if available) that corresponds to the |
| -- renamed generic formal subprogram. |
| |
| Root_Typ : Entity_Id := Empty; |
| -- The root type of Actual_Typ |
| |
| Formal : Node_Id; |
| |
| -- Start of processing for Find_Suitable_Candidate |
| |
| begin |
| pragma Assert (not Error_Posted (Nam)); |
| |
| Prim_Op := Empty; |
| Is_CW_Prim := False; |
| |
| -- Analyze the renamed name, but do not resolve it. The resolution |
| -- is completed once a suitable subprogram is found. |
| |
| Analyze (Nam); |
| |
| -- When the renamed name denotes the intrinsic operator equals, |
| -- the name must be treated as overloaded. This allows for a |
| -- potential match against the root type's predefined equality |
| -- function. |
| |
| if Is_Intrinsic_Equality (Entity (Nam)) then |
| Set_Is_Overloaded (Nam); |
| Collect_Interps (Nam); |
| end if; |
| |
| -- Step 1: Find the generic formal type and its corresponding |
| -- class-wide actual type from the renamed generic formal |
| -- subprogram. |
| |
| Formal := First_Formal (Formal_Spec); |
| while Present (Formal) loop |
| if Has_Unknown_Discriminants (Etype (Formal)) |
| and then not Is_Class_Wide_Type (Etype (Formal)) |
| and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) |
| then |
| Formal_Typ := Etype (Formal); |
| Actual_Typ := Base_Type (Get_Instance_Of (Formal_Typ)); |
| Root_Typ := Root_Type (Actual_Typ); |
| exit; |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| -- The specification of the generic formal subprogram should |
| -- always contain a formal type with unknown discriminants whose |
| -- actual is a class-wide type; otherwise this indicates a failure |
| -- in function Has_Class_Wide_Actual. |
| |
| pragma Assert (Present (Formal_Typ)); |
| |
| -- Step 2: Find the proper class-wide subprogram or primitive |
| -- that corresponds to the renamed generic formal subprogram. |
| |
| CW_Prim_Op := Find_Primitive (Actual_Typ); |
| CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); |
| Root_Prim_Op := Find_Primitive (Root_Typ); |
| Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); |
| |
| -- The class-wide actual type has two subprograms that correspond |
| -- to the renamed generic formal subprogram: |
| |
| -- with procedure Prim_Op (Param : Formal_Typ); |
| |
| -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited |
| -- procedure Prim_Op (Param : Actual_Typ'Class); |
| |
| -- Even though the declaration of the two subprograms is legal, a |
| -- call to either one is ambiguous and therefore illegal. |
| |
| if CW_Prim_OK and Root_Prim_OK then |
| |
| -- A user-defined primitive has precedence over a predefined |
| -- one. |
| |
| if Is_Internal (CW_Prim_Op) |
| and then not Is_Internal (Root_Prim_Op) |
| then |
| Prim_Op := Root_Prim_Op; |
| |
| elsif Is_Internal (Root_Prim_Op) |
| and then not Is_Internal (CW_Prim_Op) |
| then |
| Prim_Op := CW_Prim_Op; |
| Is_CW_Prim := True; |
| |
| elsif CW_Prim_Op = Root_Prim_Op then |
| Prim_Op := Root_Prim_Op; |
| |
| -- The two subprograms are legal but the class-wide subprogram |
| -- is a class-wide wrapper built for a previous instantiation; |
| -- the wrapper has precedence. |
| |
| elsif Present (Alias (CW_Prim_Op)) |
| and then Is_Class_Wide_Wrapper (Ultimate_Alias (CW_Prim_Op)) |
| then |
| Prim_Op := CW_Prim_Op; |
| Is_CW_Prim := True; |
| |
| -- Otherwise both candidate subprograms are user-defined and |
| -- ambiguous. |
| |
| else |
| Error_Msg_NE |
| ("ambiguous actual for generic subprogram &", |
| Spec, Formal_Spec); |
| Interpretation_Error (Root_Prim_Op); |
| Interpretation_Error (CW_Prim_Op); |
| return; |
| end if; |
| |
| elsif CW_Prim_OK and not Root_Prim_OK then |
| Prim_Op := CW_Prim_Op; |
| Is_CW_Prim := True; |
| |
| elsif not CW_Prim_OK and Root_Prim_OK then |
| Prim_Op := Root_Prim_Op; |
| |
| -- An intrinsic equality may act as a suitable candidate in the |
| -- case of a null type extension where the parent's equality |
| -- is hidden. A call to an intrinsic equality is expanded as |
| -- dispatching. |
| |
| elsif Present (Root_Prim_Op) |
| and then Is_Intrinsic_Equality (Root_Prim_Op) |
| then |
| Prim_Op := Root_Prim_Op; |
| |
| -- Otherwise there are no candidate subprograms. Let the caller |
| -- diagnose the error. |
| |
| else |
| return; |
| end if; |
| |
| -- At this point resolution has taken place and the name is no |
| -- longer overloaded. Mark the primitive as referenced. |
| |
| Set_Is_Overloaded (Name (N), False); |
| Set_Referenced (Prim_Op); |
| end Find_Suitable_Candidate; |
| |
| -- Local variables |
| |
| Is_CW_Prim : Boolean; |
| |
| -- Start of processing for Handle_Instance_With_Class_Wide_Type |
| |
| begin |
| Wrapped_Prim := Empty; |
| Wrap_Id := Empty; |
| |
| -- Ada 2012 (AI05-0071): A generic/instance scenario involving a |
| -- formal type with unknown discriminants and a generic primitive |
| -- operation of the said type with a box require special processing |
| -- when the actual is a class-wide type: |
| -- |
| -- generic |
| -- type Formal_Typ (<>) is private; |
| -- with procedure Prim_Op (Param : Formal_Typ) is <>; |
| -- package Gen is ... |
| -- |
| -- package Inst is new Gen (Actual_Typ'Class); |
| -- |
| -- In this case the general renaming mechanism used in the prologue |
| -- of an instance no longer applies: |
| -- |
| -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; |
| -- |
| -- The above is replaced the following wrapper/renaming combination: |
| -- |
| -- procedure Wrapper (Param : Formal_Typ) is -- wrapper |
| -- begin |
| -- Prim_Op (Param); -- primitive |
| -- end Wrapper; |
| -- |
| -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper; |
| -- |
| -- This transformation applies only if there is no explicit visible |
| -- class-wide operation at the point of the instantiation. Ren_Id is |
| -- the entity of the renaming declaration. When the transformation |
| -- applies, Wrapped_Prim is the entity of the wrapped primitive. |
| |
| if Box_Present (Inst_Node) then |
| Find_Suitable_Candidate |
| (Prim_Op => Wrapped_Prim, |
| Is_CW_Prim => Is_CW_Prim); |
| |
| if Present (Wrapped_Prim) then |
| if not Is_CW_Prim then |
| Build_Class_Wide_Wrapper (Ren_Id, Wrapped_Prim, Wrap_Id); |
| |
| -- Small optimization: When the candidate is a class-wide |
| -- subprogram we don't build the wrapper; we modify the |
| -- renaming declaration to directly map the actual to the |
| -- generic formal and discard the candidate. |
| |
| else |
| Rewrite (Nam, New_Occurrence_Of (Wrapped_Prim, Sloc (N))); |
| Wrapped_Prim := Empty; |
| end if; |
| end if; |
| |
| -- Ada 2022 (AI12-0165, RM 12.6(8.5/3)): The actual subprogram for a |
| -- formal_abstract_subprogram_declaration shall be: |
| -- a) a dispatching operation of the controlling type; or |
| -- b) if the controlling type is a formal type, and the actual |
| -- type corresponding to that formal type is a specific type T, |
| -- a dispatching operation of type T; or |
| -- c) if the controlling type is a formal type, and the actual |
| -- type is a class-wide type T'Class, an implicitly declared |
| -- subprogram corresponding to a primitive operation of type T. |
| |
| elsif Nkind (Inst_Node) = N_Formal_Abstract_Subprogram_Declaration |
| and then Is_Entity_Name (Nam) |
| then |
| Find_Suitable_Candidate |
| (Prim_Op => Wrapped_Prim, |
| Is_CW_Prim => Is_CW_Prim); |
| |
| if Present (Wrapped_Prim) then |
| |
| -- Cases (a) and (b); see previous description. |
| |
| if not Is_CW_Prim then |
| Build_Class_Wide_Wrapper (Ren_Id, Wrapped_Prim, Wrap_Id); |
| |
| -- Case (c); see previous description. |
| |
| -- Implicit operations of T'Class for subtype declarations |
| -- are built by Derive_Subprogram, and their Alias attribute |
| -- references the primitive operation of T. |
| |
| elsif not Comes_From_Source (Wrapped_Prim) |
| and then Nkind (Parent (Wrapped_Prim)) = N_Subtype_Declaration |
| and then Present (Alias (Wrapped_Prim)) |
| then |
| -- We don't need to build the wrapper; we modify the |
| -- renaming declaration to directly map the actual to |
| -- the generic formal and discard the candidate. |
| |
| Rewrite (Nam, |
| New_Occurrence_Of (Alias (Wrapped_Prim), Sloc (N))); |
| Wrapped_Prim := Empty; |
| |
| -- Legality rules do not apply; discard the candidate. |
| |
| else |
| Wrapped_Prim := Empty; |
| end if; |
| end if; |
| end if; |
| end Handle_Instance_With_Class_Wide_Type; |
| |
| ------------------------- |
| -- Original_Subprogram -- |
| ------------------------- |
| |
| function Original_Subprogram (Subp : Entity_Id) return Entity_Id is |
| Orig_Decl : Node_Id; |
| Orig_Subp : Entity_Id; |
| |
| begin |
| -- First case: renamed entity is itself a renaming |
| |
| if Present (Alias (Subp)) then |
| return Alias (Subp); |
| |
| elsif Nkind (Unit_Declaration_Node (Subp)) = N_Subprogram_Declaration |
| and then Present (Corresponding_Body (Unit_Declaration_Node (Subp))) |
| then |
| -- Check if renamed entity is a renaming_as_body |
| |
| Orig_Decl := |
| Unit_Declaration_Node |
| (Corresponding_Body (Unit_Declaration_Node (Subp))); |
| |
| if Nkind (Orig_Decl) = N_Subprogram_Renaming_Declaration then |
| Orig_Subp := Entity (Name (Orig_Decl)); |
| |
| if Orig_Subp = Rename_Spec then |
| |
| -- Circularity detected |
| |
| return Orig_Subp; |
| |
| else |
| return (Original_Subprogram (Orig_Subp)); |
| end if; |
| else |
| return Subp; |
| end if; |
| else |
| return Subp; |
| end if; |
| end Original_Subprogram; |
| |
| -- Local variables |
| |
| CW_Actual : constant Boolean := Has_Class_Wide_Actual; |
| -- Ada 2012 (AI05-071, AI05-0131) and Ada 2022 (AI12-0165): True if the |
| -- renaming is for a defaulted formal subprogram when the actual for a |
| -- related formal type is class-wide. |
| |
| Inst_Node : Node_Id := Empty; |
| New_S : Entity_Id := Empty; |
| Wrapped_Prim : Entity_Id := Empty; |
| |
| -- Start of processing for Analyze_Subprogram_Renaming |
| |
| begin |
| -- We must test for the attribute renaming case before the Analyze |
| -- call because otherwise Sem_Attr will complain that the attribute |
| -- is missing an argument when it is analyzed. |
| |
| if Nkind (Nam) = N_Attribute_Reference then |
| |
| -- In the case of an abstract formal subprogram association, rewrite |
| -- an actual given by a stream or Put_Image attribute as the name of |
| -- the corresponding stream or Put_Image primitive of the type. |
| |
| -- In a generic context the stream and Put_Image operations are not |
| -- generated, and this must be treated as a normal attribute |
| -- reference, to be expanded in subsequent instantiations. |
| |
| if Is_Actual |
| and then Is_Abstract_Subprogram (Formal_Spec) |
| and then Expander_Active |
| then |
| declare |
| Prefix_Type : constant Entity_Id := Entity (Prefix (Nam)); |
| Prim : Entity_Id; |
| |
| begin |
| -- The class-wide forms of the stream and Put_Image attributes |
| -- are not primitive dispatching operations (even though they |
| -- internally dispatch). |
| |
| if Is_Class_Wide_Type (Prefix_Type) then |
| Error_Msg_N |
| ("attribute must be a primitive dispatching operation", |
| Nam); |
| return; |
| end if; |
| |
| -- Retrieve the primitive subprogram associated with the |
| -- attribute. This can only be a stream attribute, since those |
| -- are the only ones that are dispatching (and the actual for |
| -- an abstract formal subprogram must be dispatching |
| -- operation). |
| |
| case Attribute_Name (Nam) is |
| when Name_Input => |
| Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); |
| |
| when Name_Output => |
| Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); |
| |
| when Name_Read => |
| Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); |
| |
| when Name_Write => |
| Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); |
| |
| when Name_Put_Image => |
| Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Put_Image); |
| |
| when others => |
| Error_Msg_N |
| ("attribute must be a primitive dispatching operation", |
| Nam); |
| return; |
| end case; |
| |
| -- If no stream operation was found, and the type is limited, |
| -- the user should have defined one. This rule does not apply |
| -- to Put_Image. |
| |
| if No (Prim) |
| and then Attribute_Name (Nam) /= Name_Put_Image |
| then |
| if Is_Limited_Type (Prefix_Type) then |
| Error_Msg_NE |
| ("stream operation not defined for type&", |
| N, Prefix_Type); |
| return; |
| |
| -- Otherwise, compiler should have generated default |
| |
| else |
| raise Program_Error; |
| end if; |
| end if; |
| |
| -- Rewrite the attribute into the name of its corresponding |
| -- primitive dispatching subprogram. We can then proceed with |
| -- the usual processing for subprogram renamings. |
| |
| declare |
| Prim_Name : constant Node_Id := |
| Make_Identifier (Sloc (Nam), |
| Chars => Chars (Prim)); |
| begin |
| Set_Entity (Prim_Name, Prim); |
| Rewrite (Nam, Prim_Name); |
| Analyze (Nam); |
| end; |
| end; |
| |
| -- Normal processing for a renaming of an attribute |
| |
| else |
| Attribute_Renaming (N); |
| return; |
| end if; |
| end if; |
| |
| -- Check whether this declaration corresponds to the instantiation of a |
| -- formal subprogram. |
| |
| -- If this is an instantiation, the corresponding actual is frozen and |
| -- error messages can be made more precise. If this is a default |
| -- subprogram, the entity is already established in the generic, and is |
| -- not retrieved by visibility. If it is a default with a box, the |
| -- candidate interpretations, if any, have been collected when building |
| -- the renaming declaration. If overloaded, the proper interpretation is |
| -- determined in Find_Renamed_Entity. If the entity is an operator, |
| -- Find_Renamed_Entity applies additional visibility checks. |
| |
| if Is_Actual then |
| Inst_Node := Unit_Declaration_Node (Formal_Spec); |
| |
| -- Ada 2012 (AI05-0071) and Ada 2022 (AI12-0165): when the actual |
| -- type is a class-wide type T'Class we may need to wrap a primitive |
| -- operation of T. Search for the wrapped primitive and (if required) |
| -- build a wrapper whose body consists of a dispatching call to the |
| -- wrapped primitive of T, with its formal parameters as the actual |
| -- parameters. |
| |
| if CW_Actual and then |
| |
| -- Ada 2012 (AI05-0071): Check whether the renaming is for a |
| -- defaulted actual subprogram with a class-wide actual. |
| |
| (Box_Present (Inst_Node) |
| |
| or else |
| |
| -- Ada 2022 (AI12-0165): Check whether the renaming is for a formal |
| -- abstract subprogram declaration with a class-wide actual. |
| |
| (Nkind (Inst_Node) = N_Formal_Abstract_Subprogram_Declaration |
| and then Is_Entity_Name (Nam))) |
| then |
| New_S := Analyze_Subprogram_Specification (Spec); |
| |
| -- Do not attempt to build the wrapper if the renaming is in error |
| |
| if not Error_Posted (Nam) then |
| Handle_Instance_With_Class_Wide_Type |
| (Inst_Node => Inst_Node, |
| Ren_Id => New_S, |
| Wrapped_Prim => Wrapped_Prim, |
| Wrap_Id => Old_S); |
| |
| -- If several candidates were found, then we reported the |
| -- ambiguity; stop processing the renaming declaration to |
| -- avoid reporting further (spurious) errors. |
| |
| if Error_Posted (Spec) then |
| return; |
| end if; |
| |
| end if; |
| end if; |
| |
| if Present (Wrapped_Prim) then |
| |
| -- When the wrapper is built, the subprogram renaming aliases |
| -- the wrapper. |
| |
| Analyze (Nam); |
| |
| pragma Assert (Old_S = Entity (Nam) |
| and then Is_Class_Wide_Wrapper (Old_S)); |
| |
| -- The subprogram renaming declaration may become Ghost if it |
| -- renames a wrapper of a Ghost entity. |
| |
| Mark_Ghost_Renaming (N, Wrapped_Prim); |
| |
| elsif Is_Entity_Name (Nam) |
| and then Present (Entity (Nam)) |
| and then not Comes_From_Source (Nam) |
| and then not Is_Overloaded (Nam) |
| then |
| Old_S := Entity (Nam); |
| |
| -- The subprogram renaming declaration may become Ghost if it |
| -- renames a Ghost entity. |
| |
| Mark_Ghost_Renaming (N, Old_S); |
| |
| New_S := Analyze_Subprogram_Specification (Spec); |
| |
| -- Operator case |
| |
| if Ekind (Old_S) = E_Operator then |
| |
| -- Box present |
| |
| if Box_Present (Inst_Node) then |
| Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); |
| |
| -- If there is an immediately visible homonym of the operator |
| -- and the declaration has a default, this is worth a warning |
| -- because the user probably did not intend to get the pre- |
| -- defined operator, visible in the generic declaration. To |
| -- find if there is an intended candidate, analyze the renaming |
| -- again in the current context. |
| |
| elsif Scope (Old_S) = Standard_Standard |
| and then Present (Default_Name (Inst_Node)) |
| then |
| declare |
| Decl : constant Node_Id := New_Copy_Tree (N); |
| Hidden : Entity_Id; |
| |
| begin |
| Set_Entity (Name (Decl), Empty); |
| Analyze (Name (Decl)); |
| Hidden := |
| Find_Renamed_Entity (Decl, Name (Decl), New_S, True); |
| |
| if Present (Hidden) |
| and then In_Open_Scopes (Scope (Hidden)) |
| and then Is_Immediately_Visible (Hidden) |
| and then Comes_From_Source (Hidden) |
| and then Hidden /= Old_S |
| then |
| Error_Msg_Sloc := Sloc (Hidden); |
| Error_Msg_N |
| ("default subprogram is resolved in the generic " |
| & "declaration (RM 12.6(17))??", N); |
| Error_Msg_NE ("\and will not use & #??", N, Hidden); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| else |
| Analyze (Nam); |
| |
| -- The subprogram renaming declaration may become Ghost if it |
| -- renames a Ghost entity. |
| |
| if Is_Entity_Name (Nam) then |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| end if; |
| |
| New_S := Analyze_Subprogram_Specification (Spec); |
| end if; |
| |
| else |
| -- Renamed entity must be analyzed first, to avoid being hidden by |
| -- new name (which might be the same in a generic instance). |
| |
| Analyze (Nam); |
| |
| -- The subprogram renaming declaration may become Ghost if it renames |
| -- a Ghost entity. |
| |
| if Is_Entity_Name (Nam) then |
| Mark_Ghost_Renaming (N, Entity (Nam)); |
| end if; |
| |
| -- The renaming defines a new overloaded entity, which is analyzed |
| -- like a subprogram declaration. |
| |
| New_S := Analyze_Subprogram_Specification (Spec); |
| end if; |
| |
| if Current_Scope /= Standard_Standard then |
| Set_Is_Pure (New_S, Is_Pure (Current_Scope)); |
| end if; |
| |
| -- Set SPARK mode from current context |
| |
| Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (New_S); |
| |
| Rename_Spec := Find_Corresponding_Spec (N); |
| |
| -- Case of Renaming_As_Body |
| |
| if Present (Rename_Spec) then |
| Check_Previous_Null_Procedure (N, Rename_Spec); |
| |
| -- Renaming declaration is the completion of the declaration of |
| -- Rename_Spec. We build an actual body for it at the freezing point. |
| |
| Set_Corresponding_Spec (N, Rename_Spec); |
| |
| -- Deal with special case of stream functions of abstract types |
| -- and interfaces. |
| |
| if Nkind (Unit_Declaration_Node (Rename_Spec)) = |
| N_Abstract_Subprogram_Declaration |
| then |
| -- Input stream functions are abstract if the object type is |
| -- abstract. Similarly, all default stream functions for an |
| -- interface type are abstract. However, these subprograms may |
| -- receive explicit declarations in representation clauses, making |
| -- the attribute subprograms usable as defaults in subsequent |
| -- type extensions. |
| -- In this case we rewrite the declaration to make the subprogram |
| -- non-abstract. We remove the previous declaration, and insert |
| -- the new one at the point of the renaming, to prevent premature |
| -- access to unfrozen types. The new declaration reuses the |
| -- specification of the previous one, and must not be analyzed. |
| |
| pragma Assert |
| (Is_Primitive (Entity (Nam)) |
| and then |
| Is_Abstract_Type (Find_Dispatching_Type (Entity (Nam)))); |
| declare |
| Old_Decl : constant Node_Id := |
| Unit_Declaration_Node (Rename_Spec); |
| New_Decl : constant Node_Id := |
| Make_Subprogram_Declaration (Sloc (N), |
| Specification => |
| Relocate_Node (Specification (Old_Decl))); |
| begin |
| Remove (Old_Decl); |
| Insert_After (N, New_Decl); |
| Set_Is_Abstract_Subprogram (Rename_Spec, False); |
| Set_Analyzed (New_Decl); |
| end; |
| end if; |
| |
| Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S); |
| |
| if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
| Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N); |
| end if; |
| |
| Set_Convention (New_S, Convention (Rename_Spec)); |
| Check_Fully_Conformant (New_S, Rename_Spec); |
| Set_Public_Status (New_S); |
| |
| if No_Return (Rename_Spec) |
| and then not No_Return (Entity (Nam)) |
| then |
| Error_Msg_NE |
| ("renamed subprogram & must be No_Return", N, Entity (Nam)); |
| Error_Msg_N |
| ("\since renaming subprogram is No_Return (RM 6.5.1(7/2))", N); |
| end if; |
| |
| -- The specification does not introduce new formals, but only |
| -- repeats the formals of the original subprogram declaration. |
| -- For cross-reference purposes, and for refactoring tools, we |
| -- treat the formals of the renaming declaration as body formals. |
| |
| Reference_Body_Formals (Rename_Spec, New_S); |
| |
| -- Indicate that the entity in the declaration functions like the |
| -- corresponding body, and is not a new entity. The body will be |
| -- constructed later at the freeze point, so indicate that the |
| -- completion has not been seen yet. |
| |
| Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter); |
| Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals, |
| Old_Ekind => (E_Function | E_Procedure => True, others => False)); |
| Mutate_Ekind (New_S, E_Subprogram_Body); |
| New_S := Rename_Spec; |
| Set_Has_Completion (Rename_Spec, False); |
| |
| -- Ada 2005: check overriding indicator |
| |
| if Present (Overridden_Operation (Rename_Spec)) then |
| if Must_Not_Override (Specification (N)) then |
| Error_Msg_NE |
| ("subprogram& overrides inherited operation", |
| N, Rename_Spec); |
| |
| elsif Style_Check |
| and then not Must_Override (Specification (N)) |
| then |
| Style.Missing_Overriding (N, Rename_Spec); |
| end if; |
| |
| elsif Must_Override (Specification (N)) |
| and then not Can_Override_Operator (Rename_Spec) |
| then |
| Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); |
| end if; |
| |
| -- AI12-0132: a renames-as-body freezes the expression of any |
| -- expression function that it renames. |
| |
| if Is_Entity_Name (Nam) |
| and then Is_Expression_Function (Entity (Nam)) |
| and then not Inside_A_Generic |
| then |
| Freeze_Expr_Types |
| (Def_Id => Entity (Nam), |
| Typ => Etype (Entity (Nam)), |
| Expr => |
| Expression |
| (Original_Node (Unit_Declaration_Node (Entity (Nam)))), |
| N => N); |
| end if; |
| |
| -- Normal subprogram renaming (not renaming as body) |
| |
| else |
| Generate_Definition (New_S); |
| New_Overloaded_Entity (New_S); |
| |
| if not (Is_Entity_Name (Nam) |
| and then Is_Intrinsic_Subprogram (Entity (Nam))) |
| then |
| Check_Delayed_Subprogram (New_S); |
| end if; |
| |
| -- Verify that a SPARK renaming does not declare a primitive |
| -- operation of a tagged type. |
| |
| Check_SPARK_Primitive_Operation (New_S); |
| end if; |
| |
| -- There is no need for elaboration checks on the new entity, which may |
| -- be called before the next freezing point where the body will appear. |
| -- Elaboration checks refer to the real entity, not the one created by |
| -- the renaming declaration. |
| |
| Set_Kill_Elaboration_Checks (New_S, True); |
| |
| -- If we had a previous error, indicate a completion is present to stop |
| -- junk cascaded messages, but don't take any further action. |
| |
| if Etype (Nam) = Any_Type then |
| Set_Has_Completion (New_S); |
| return; |
| |
| -- Case where name has the form of a selected component |
| |
| elsif Nkind (Nam) = N_Selected_Component then |
| |
| -- A name which has the form A.B can designate an entry of task A, a |
| -- protected operation of protected object A, or finally a primitive |
| -- operation of object A. In the later case, A is an object of some |
| -- tagged type, or an access type that denotes one such. To further |
| -- distinguish these cases, note that the scope of a task entry or |
| -- protected operation is type of the prefix. |
| |
| -- The prefix could be an overloaded function call that returns both |
| -- kinds of operations. This overloading pathology is left to the |
| -- dedicated reader ??? |
| |
| declare |
| T : constant Entity_Id := Etype (Prefix (Nam)); |
| |
| begin |
| if Present (T) |
| and then |
| (Is_Tagged_Type (T) |
| or else |
| (Is_Access_Type (T) |
| and then Is_Tagged_Type (Designated_Type (T)))) |
| and then Scope (Entity (Selector_Name (Nam))) /= T |
| then |
| Analyze_Renamed_Primitive_Operation |
| (N, New_S, Present (Rename_Spec)); |
| return; |
| |
| else |
| -- Renamed entity is an entry or protected operation. For those |
| -- cases an explicit body is built (at the point of freezing of |
| -- this entity) that contains a call to the renamed entity. |
| |
| -- This is not allowed for renaming as body if the renamed |
| -- spec is already frozen (see RM 8.5.4(5) for details). |
| |
| if Present (Rename_Spec) and then Is_Frozen (Rename_Spec) then |
| Error_Msg_N |
| ("renaming-as-body cannot rename entry as subprogram", N); |
| Error_Msg_NE |
| ("\since & is already frozen (RM 8.5.4(5))", |
| N, Rename_Spec); |
| else |
| Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec)); |
| end if; |
| |
| return; |
| end if; |
| end; |
| |
| -- Case where name is an explicit dereference X.all |
| |
| elsif Nkind (Nam) = N_Explicit_Dereference then |
| |
| -- Renamed entity is designated by access_to_subprogram expression. |
| -- Must build body to encapsulate call, as in the entry case. |
| |
| Analyze_Renamed_Dereference (N, New_S, Present (Rename_Spec)); |
| return; |
| |
| -- Indexed component |
| |
| elsif Nkind (Nam) = N_Indexed_Component then |
| Analyze_Renamed_Family_Member (N, New_S, Present (Rename_Spec)); |
| return; |
| |
| -- Character literal |
| |
| elsif Nkind (Nam) = N_Character_Literal then |
| Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); |
| return; |
| |
| -- Only remaining case is where we have a non-entity name, or a renaming |
| -- of some other non-overloadable entity. |
| |
| elsif not Is_Entity_Name (Nam) |
| or else not Is_Overloadable (Entity (Nam)) |
| then |
| -- Do not mention the renaming if it comes from an instance |
| |
| if not Is_Actual then |
| Error_Msg_N ("expect valid subprogram name in renaming", N); |
| else |
| Error_Msg_NE ("no visible subprogram for formal&", N, Nam); |
| end if; |
| |
| return; |
| end if; |
| |
| -- Find the renamed entity that matches the given specification. Disable |
| -- Ada_83 because there is no requirement of full conformance between |
| -- renamed entity and new entity, even though the same circuit is used. |
| |
| -- This is a bit of an odd case, which introduces a really irregular use |
| -- of Ada_Version[_Explicit]. Would be nice to find cleaner way to do |
| -- this. ??? |
| |
| Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95); |
| Ada_Version_Pragma := Empty; |
| Ada_Version_Explicit := Ada_Version; |
| |
| if No (Old_S) then |
| Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); |
| |
| -- The visible operation may be an inherited abstract operation that |
| -- was overridden in the private part, in which case a call will |
| -- dispatch to the overriding operation. Use the overriding one in |
| -- the renaming declaration, to prevent spurious errors below. |
| |
| if Is_Overloadable (Old_S) |
| and then Is_Abstract_Subprogram (Old_S) |
| and then No (DTC_Entity (Old_S)) |
| and then Present (Alias (Old_S)) |
| and then not Is_Abstract_Subprogram (Alias (Old_S)) |
| and then Present (Overridden_Operation (Alias (Old_S))) |
| then |
| Old_S := Alias (Old_S); |
| end if; |
| |
| -- When the renamed subprogram is overloaded and used as an actual |
| -- of a generic, its entity is set to the first available homonym. |
| -- We must first disambiguate the name, then set the proper entity. |
| |
| if Is_Actual and then Is_Overloaded (Nam) then |
| Set_Entity (Nam, Old_S); |
| end if; |
| end if; |
| |
| -- Most common case: subprogram renames subprogram. No body is generated |
| -- in this case, so we must indicate the declaration is complete as is. |
| -- and inherit various attributes of the renamed subprogram. |
| |
| if No (Rename_Spec) then |
| Set_Has_Completion (New_S); |
| Set_Is_Imported (New_S, Is_Imported (Entity (Nam))); |
| Set_Is_Pure (New_S, Is_Pure (Entity (Nam))); |
| Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam))); |
| |
| -- Ada 2005 (AI-423): Check the consistency of null exclusions |
| -- between a subprogram and its correct renaming. |
| |
| -- Note: the Any_Id check is a guard that prevents compiler crashes |
| -- when performing a null exclusion check between a renaming and a |
| -- renamed subprogram that has been found to be illegal. |
| |
| if Ada_Version >= Ada_2005 and then Entity (Nam) /= Any_Id then |
| Check_Null_Exclusion |
| (Ren => New_S, |
| Sub => Entity (Nam)); |
| end if; |
| |
| -- Enforce the Ada 2005 rule that the renamed entity cannot require |
| -- overriding. The flag Requires_Overriding is set very selectively |
| -- and misses some other illegal cases. The additional conditions |
| -- checked below are sufficient but not necessary ??? |
| |
| -- The rule does not apply to the renaming generated for an actual |
| -- subprogram in an instance. |
| |
| if Is_Actual then |
| null; |
| |
| -- Guard against previous errors, and omit renamings of predefined |
| -- operators. |
| |
| elsif Ekind (Old_S) not in E_Function | E_Procedure then |
| null; |
| |
| elsif Requires_Overriding (Old_S) |
| or else |
| (Is_Abstract_Subprogram (Old_S) |
| and then Present (Find_Dispatching_Type (Old_S)) |
| and then not Is_Abstract_Type (Find_Dispatching_Type (Old_S))) |
| then |
| Error_Msg_N |
| ("renamed entity cannot be subprogram that requires overriding " |
| & "(RM 8.5.4 (5.1))", N); |
| end if; |
| |
| declare |
| Prev : constant Entity_Id := Overridden_Operation (New_S); |
| begin |
| if Present (Prev) |
| and then |
| (Has_Non_Trivial_Precondition (Prev) |
| or else Has_Non_Trivial_Precondition (Old_S)) |
| then |
| Error_Msg_NE |
| ("conflicting inherited classwide preconditions in renaming " |
| & "of& (RM 6.1.1 (17)", N, Old_S); |
| end if; |
| end; |
| end if; |
| |
| if Old_S /= Any_Id then |
| if Is_Actual and then From_Default (N) then |
| |
| -- This is an implicit reference to the default actual |
| |
| Generate_Reference (Old_S, Nam, Typ => 'i', Force => True); |
| |
| else |
| Generate_Reference (Old_S, Nam); |
| end if; |
| |
| Check_Internal_Protected_Use (N, Old_S); |
| |
| -- For a renaming-as-body, require subtype conformance, but if the |
| -- declaration being completed has not been frozen, then inherit the |
| -- convention of the renamed subprogram prior to checking conformance |
| -- (unless the renaming has an explicit convention established; the |
| -- rule stated in the RM doesn't seem to address this ???). |
| |
| if Present (Rename_Spec) then |
| Generate_Reference (Rename_Spec, Defining_Entity (Spec), 'b'); |
| Style.Check_Identifier (Defining_Entity (Spec), Rename_Spec); |
| |
| if not Is_Frozen (Rename_Spec) then |
| if not Has_Convention_Pragma (Rename_Spec) then |
| Set_Convention (New_S, Convention (Old_S)); |
| end if; |
| |
| if Ekind (Old_S) /= E_Operator then |
| Check_Mode_Conformant (New_S, Old_S, Spec); |
| end if; |
| |
| if Original_Subprogram (Old_S) = Rename_Spec then |
| Error_Msg_N ("unfrozen subprogram cannot rename itself", N); |
| else |
| Check_Formal_Subprogram_Conformance (New_S, Old_S, Spec); |
| end if; |
| else |
| Check_Subtype_Conformant (New_S, Old_S, Spec); |
| end if; |
| |
| Check_Frozen_Renaming (N, Rename_Spec); |
| |
| -- Check explicitly that renamed entity is not intrinsic, because |
| -- in a generic the renamed body is not built. In this case, |
| -- the renaming_as_body is a completion. |
| |
| if Inside_A_Generic then |
| if Is_Frozen (Rename_Spec) |
| and then Is_Intrinsic_Subprogram (Old_S) |
| then |
| Error_Msg_N |
| ("subprogram in renaming_as_body cannot be intrinsic", |
| Name (N)); |
| end if; |
| |
| Set_Has_Completion (Rename_Spec); |
| end if; |
| |
| elsif Ekind (Old_S) /= E_Operator then |
| |
| -- If this a defaulted subprogram for a class-wide actual there is |
| -- no check for mode conformance, given that the signatures don't |
| -- match (the source mentions T but the actual mentions T'Class). |
| |
| if CW_Actual then |
| null; |
| |
| -- No need for a redundant error message if this is a nested |
| -- instance, unless the current instantiation (of a child unit) |
| -- is a compilation unit, which is not analyzed when the parent |
| -- generic is analyzed. |
| |
| elsif not Is_Actual |
| or else No (Enclosing_Instance) |
| or else Is_Compilation_Unit (Current_Scope) |
| then |
| Check_Mode_Conformant (New_S, Old_S); |
| end if; |
| end if; |
| |
| if No (Rename_Spec) then |
| |
| -- The parameter profile of the new entity is that of the renamed |
| -- entity: the subtypes given in the specification are irrelevant. |
| |
| Inherit_Renamed_Profile (New_S, Old_S); |
| |
| -- A call to the subprogram is transformed into a call to the |
| -- renamed entity. This is transitive if the renamed entity is |
| -- itself a renaming. |
| |
| if Present (Alias (Old_S)) then |
| Set_Alias (New_S, Alias (Old_S)); |
| else |
| Set_Alias (New_S, Old_S); |
| end if; |
| |
| -- Note that we do not set Is_Intrinsic_Subprogram if we have a |
| -- renaming as body, since the entity in this case is not an |
| -- intrinsic (it calls an intrinsic, but we have a real body for |
| -- this call, and it is in this body that the required intrinsic |
| -- processing will take place). |
| |
| -- Also, if this is a renaming of inequality, the renamed operator |
| -- is intrinsic, but what matters is the corresponding equality |
| -- operator, which may be user-defined. |
| |
| Set_Is_Intrinsic_Subprogram |
| (New_S, |
| Is_Intrinsic_Subprogram (Old_S) |
| and then |
| (Chars (Old_S) /= Name_Op_Ne |
| or else Ekind (Old_S) = E_Operator |
| or else Is_Intrinsic_Subprogram |
| (Corresponding_Equality (Old_S)))); |
| |
| if Ekind (Alias (New_S)) = E_Operator then |
| Set_Has_Delayed_Freeze (New_S, False); |
| end if; |
| |
| -- If the renaming corresponds to an association for an abstract |
| -- formal subprogram, then various attributes must be set to |
| -- indicate that the renaming is an abstract dispatching operation |
| -- with a controlling type. |
| |
| -- Skip this decoration when the renaming corresponds to an |
| -- association with class-wide wrapper (see above) because such |
| -- wrapper is neither abstract nor a dispatching operation (its |
| -- body has the dispatching call to the wrapped primitive). |
| |
| if Is_Actual |
| and then Is_Abstract_Subprogram (Formal_Spec) |
| and then No (Wrapped_Prim) |
| then |
| |
| -- Mark the renaming as abstract here, so Find_Dispatching_Type |
| -- see it as corresponding to a generic association for a |
| -- formal abstract subprogram |
| |
| Set_Is_Abstract_Subprogram (New_S); |
| |
| declare |
| New_S_Ctrl_Type : constant Entity_Id := |
| Find_Dispatching_Type (New_S); |
| Old_S_Ctrl_Type : constant Entity_Id := |
| Find_Dispatching_Type (Old_S); |
| |
| begin |
| |
| -- The actual must match the (instance of the) formal, |
| -- and must be a controlling type. |
| |
| if Old_S_Ctrl_Type /= New_S_Ctrl_Type |
| or else No (New_S_Ctrl_Type) |
| then |
| if No (New_S_Ctrl_Type) then |
| Error_Msg_N |
| ("actual must be dispatching subprogram", Nam); |
| else |
| Error_Msg_NE |
| ("actual must be dispatching subprogram for type&", |
| Nam, New_S_Ctrl_Type); |
| end if; |
| |
| else |
| Set_Is_Dispatching_Operation (New_S); |
| Check_Controlling_Formals (New_S_Ctrl_Type, New_S); |
| |
| -- If the actual in the formal subprogram is itself a |
| -- formal abstract subprogram association, there's no |
| -- dispatch table component or position to inherit. |
| |
| if Present (DTC_Entity (Old_S)) then |
| Set_DTC_Entity (New_S, DTC_Entity (Old_S)); |
| Set_DT_Position_Value (New_S, DT_Position (Old_S)); |
| end if; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| if Is_Actual then |
| null; |
| |
| -- The following is illegal, because F hides whatever other F may |
| -- be around: |
| -- function F (...) renames F; |
| |
| elsif Old_S = New_S |
| or else (Nkind (Nam) /= N_Expanded_Name |
| and then Chars (Old_S) = Chars (New_S)) |
| then |
| Error_Msg_N ("subprogram cannot rename itself", N); |
| |
| -- This is illegal even if we use a selector: |
| -- function F (...) renames Pkg.F; |
| -- because F is still hidden. |
| |
| elsif Nkind (Nam) = N_Expanded_Name |
| and then Entity (Prefix (Nam)) = Current_Scope |
| and then Chars (Selector_Name (Nam)) = Chars (New_S) |
| then |
| -- This is an error, but we overlook the error and accept the |
| -- renaming if the special Overriding_Renamings mode is in effect. |
| |
| if not Overriding_Renamings then |
| Error_Msg_NE |
| ("implicit operation& is not visible (RM 8.3 (15))", |
| Nam, Old_S); |
| end if; |
| |
| -- Check whether an expanded name used for the renamed subprogram |
| -- begins with the same name as the renaming itself, and if so, |
| -- issue an error about the prefix being hidden by the renaming. |
| -- We exclude generic instances from this checking, since such |
| -- normally illegal renamings can be constructed when expanding |
| -- instantiations. |
| |
| elsif Nkind (Nam) = N_Expanded_Name and then not In_Instance then |
| declare |
| function Ult_Expanded_Prefix (N : Node_Id) return Node_Id is |
| (if Nkind (N) /= N_Expanded_Name |
| then N |
| else Ult_Expanded_Prefix (Prefix (N))); |
| -- Returns the ultimate prefix of an expanded name |
| |
| begin |
| if Chars (Entity (Ult_Expanded_Prefix (Nam))) = Chars (New_S) |
| then |
| Error_Msg_Sloc := Sloc (N); |
| Error_Msg_NE |
| ("& is hidden by declaration#", Nam, New_S); |
| end if; |
| end; |
| end if; |
| |
| Set_Convention (New_S, Convention (Old_S)); |
| |
| if Is_Abstract_Subprogram (Old_S) then |
| if Present (Rename_Spec) then |
| Error_Msg_N |
| ("a renaming-as-body cannot rename an abstract subprogram", |
| N); |
| Set_Has_Completion (Rename_Spec); |
| else |
| Set_Is_Abstract_Subprogram (New_S); |
| end if; |
| end if; |
| |
| Check_Library_Unit_Renaming (N, Old_S); |
| |
| -- Pathological case: procedure renames entry in the scope of its |
| -- task. Entry is given by simple name, but body must be built for |
| -- procedure. Of course if called it will deadlock. |
| |
| if Ekind (Old_S) = E_Entry then |
| Set_Has_Completion (New_S, False); |
| Set_Alias (New_S, Empty); |
| end if; |
| |
| -- Do not freeze the renaming nor the renamed entity when the context |
| -- is an enclosing generic. Freezing is an expansion activity, and in |
| -- addition the renamed entity may depend on the generic formals of |
| -- the enclosing generic. |
| |
| if Is_Actual and not Inside_A_Generic then |
| Freeze_Before (N, Old_S); |
| Freeze_Actual_Profile; |
| Set_Has_Delayed_Freeze (New_S, False); |
| Freeze_Before (N, New_S); |
| |
| if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) |
| and then not Is_Abstract_Subprogram (Formal_Spec) |
| then |
| -- An abstract subprogram is only allowed as an actual in the |
| -- case where the formal subprogram is also abstract. |
| |
| if Is_Abstract_Subprogram (Old_S) then |
| Error_Msg_N |
| ("abstract subprogram not allowed as generic actual", Nam); |
| end if; |
| |
| -- AI12-0412: A primitive of an abstract type with Pre'Class |
| -- or Post'Class aspects specified with nonstatic expressions |
| -- is not allowed as actual for a nonabstract formal subprogram |
| -- (see RM 6.1.1(18.2/5). |
| |
| if Is_Dispatching_Operation (Old_S) |
| and then |
| Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Old_S) |
| then |
| Error_Msg_N |
| ("primitive of abstract type with nonstatic class-wide " |
| & "pre/postconditions not allowed as actual", |
| Nam); |
| end if; |
| end if; |
| end if; |
| |
| else |
| -- A common error is to assume that implicit operators for types are |
| -- defined in Standard, or in the scope of a subtype. In those cases |
| -- where the renamed entity is given with an expanded name, it is |
| -- worth mentioning that operators for the type are not declared in |
| -- the scope given by the prefix. |
| |
| if Nkind (Nam) = N_Expanded_Name |
| and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol |
| and then Scope (Entity (Nam)) = Standard_Standard |
| then |
| declare |
| T : constant Entity_Id := |
| Base_Type (Etype (First_Formal (New_S))); |
| begin |
| Error_Msg_Node_2 := Prefix (Nam); |
| Error_Msg_NE |
| ("operator for type& is not declared in&", Prefix (Nam), T); |
| end; |
| |
| else |
| Error_Msg_NE |
| ("no visible subprogram matches the specification for&", |
| Spec, New_S); |
| end if; |
| |
| if Present (Candidate_Renaming) then |
| declare |
| F1 : Entity_Id; |
| F2 : Entity_Id; |
| T1 : Entity_Id; |
| |
| begin |
| F1 := First_Formal (Candidate_Renaming); |
| F2 := First_Formal (New_S); |
| T1 := First_Subtype (Etype (F1)); |
| while Present (F1) and then Present (F2) loop |
| Next_Formal (F1); |
| Next_Formal (F2); |
| end loop; |
| |
| if Present (F1) and then Present (Default_Value (F1)) then |
| if Present (Next_Formal (F1)) then |
| Error_Msg_NE |
| ("\missing specification for & and other formals with " |
| & "defaults", Spec, F1); |
| else |
| Error_Msg_NE ("\missing specification for &", Spec, F1); |
| end if; |
| end if; |
| |
| if Nkind (Nam) = N_Operator_Symbol |
| and then From_Default (N) |
| then |
| Error_Msg_Node_2 := T1; |
| Error_Msg_NE |
| ("default & on & is not directly visible", Nam, Nam); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that |
| -- controlling access parameters are known non-null for the renamed |
| -- subprogram. Test also applies to a subprogram instantiation that |
| -- is dispatching. Test is skipped if some previous error was detected |
| -- that set Old_S to Any_Id. |
| |
| if Ada_Version >= Ada_2005 |
| and then Old_S /= Any_Id |
| and then not Is_Dispatching_Operation (Old_S) |
| and then Is_Dispatching_Operation (New_S) |
| then |
| declare |
| Old_F : Entity_Id; |
| New_F : Entity_Id; |
| |
| begin |
| Old_F := First_Formal (Old_S); |
| New_F := First_Formal (New_S); |
| while Present (Old_F) loop |
| if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type |
| and then Is_Controlling_Formal (New_F) |
| and then not Can_Never_Be_Null (Old_F) |
| then |
| Error_Msg_N ("access parameter is controlling,", New_F); |
| Error_Msg_NE |
| ("\corresponding parameter of& must be explicitly null " |
| & "excluding", New_F, Old_S); |
| end if; |
| |
| Next_Formal (Old_F); |
| Next_Formal (New_F); |
| end loop; |
| end; |
| end if; |
| |
| -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005) |
| -- is to warn if an operator is being renamed as a different operator. |
| -- If the operator is predefined, examine the kind of the entity, not |
| -- the abbreviated declaration in Standard. |
| |
| if Comes_From_Source (N) |
| and then Present (Old_S) |
| and then (Nkind (Old_S) = N_Defining_Operator_Symbol |
| or else Ekind (Old_S) = E_Operator) |
| and then Nkind (New_S) = N_Defining_Operator_Symbol |
| and then Chars (Old_S) /= Chars (New_S) |
| then |
| Error_Msg_NE |
| ("& is being renamed as a different operator??", N, Old_S); |
| end if; |
| |
| -- Check for renaming of obsolescent subprogram |
| |
| Check_Obsolescent_2005_Entity (Entity (Nam), Nam); |
| |
| -- Another warning or some utility: if the new subprogram as the same |
| -- name as the old one, the old one is not hidden by an outer homograph, |
| -- the new one is not a public symbol, and the old one is otherwise |
| -- directly visible, the renaming is superfluous. |
| |
| if Chars (Old_S) = Chars (New_S) |
| and then Comes_From_Source (N) |
| and then Scope (Old_S) /= Standard_Standard |
| and then Warn_On_Redundant_Constructs |
| and then (Is_Immediately_Visible (Old_S) |
| or else Is_Potentially_Use_Visible (Old_S)) |
| and then Is_Overloadable (Current_Scope) |
| and then Chars (Current_Scope) /= Chars (Old_S) |
| then |
| Error_Msg_N |
| ("redundant renaming, entity is directly visible?r?", Name (N)); |
| end if; |
| |
| -- Implementation-defined aspect specifications can appear in a renaming |
| -- declaration, but not language-defined ones. The call to procedure |
| -- Analyze_Aspect_Specifications will take care of this error check. |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, New_S); |
| end if; |
| |
| -- AI12-0279 |
| |
| if Is_Actual |
| and then Has_Yield_Aspect (Formal_Spec) |
| and then not Has_Yield_Aspect (Old_S) |
| then |
| Error_Msg_Name_1 := Name_Yield; |
| Error_Msg_N |
| ("actual subprogram& must have aspect% to match formal", Name (N)); |
| end if; |
| |
| Ada_Version := Save_AV; |
| Ada_Version_Pragma := Save_AVP; |
| Ada_Version_Explicit := Save_AV_Exp; |
| |
| -- Check if we are looking at an Ada 2012 defaulted formal subprogram |
| -- and mark any use_package_clauses that affect the visibility of the |
| -- implicit generic actual. |
| |
| -- Also, we may be looking at an internal renaming of a user-defined |
| -- subprogram created for a generic formal subprogram association, |
| -- which will also have to be marked here. This can occur when the |
| -- corresponding formal subprogram contains references to other generic |
| -- formals. |
| |
| if Is_Generic_Actual_Subprogram (New_S) |
| and then (Is_Intrinsic_Subprogram (New_S) |
| or else From_Default (N) |
| or else Nkind (N) = N_Subprogram_Renaming_Declaration) |
|