| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 8 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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 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_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.CN; use Sinfo.CN; |
| with Snames; use Snames; |
| with Style; |
| with Table; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| 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 : Node_Id; |
| 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 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_Most_Prev (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. |
| -- ??? a better subprogram name is in order |
| |
| 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_Implicit_Operator (N : Node_Id) return Boolean; |
| -- N is an expanded name whose selector is an operator name (e.g. P."+"). |
| -- 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 Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; |
| -- True if it is of a task type, a protected type, or else an access to one |
| -- of these types. |
| |
| function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; |
| -- Prefix is appropriate for record if it is of a record type, or an access |
| -- to such. |
| |
| 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. |
| -- ??? a better subprogram name is in order |
| |
| 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 |
| Check_SPARK_05_Restriction ("exception renaming is not allowed", N); |
| |
| Enter_Name (Id); |
| Analyze (Nam); |
| |
| Set_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_Object (Entity (Nam))) then |
| Set_Renamed_Object (Id, Renamed_Object (Entity (Nam))); |
| else |
| Set_Renamed_Object (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; |
| |
| Check_SPARK_05_Restriction ("generic renaming is not allowed", N); |
| |
| 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); |
| Set_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_Object (Old_P)) then |
| Set_Renamed_Object (New_P, Renamed_Object (Old_P)); |
| else |
| Set_Renamed_Object (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 Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) 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); |
| Dec : Node_Id; |
| T : Entity_Id; |
| T2 : Entity_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. |
| |
| ------------------------------ |
| -- Check_Constrained_Object -- |
| ------------------------------ |
| |
| procedure Check_Constrained_Object is |
| Typ : constant Entity_Id := Etype (Nam); |
| Subt : Entity_Id; |
| |
| begin |
| if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference) |
| and then Is_Composite_Type (Etype (Nam)) |
| and then not Is_Constrained (Etype (Nam)) |
| and then not Has_Unknown_Discriminants (Etype (Nam)) |
| and then Expander_Active |
| then |
| -- If Actual_Subtype is already set, nothing to do |
| |
| if Ekind_In (Id, 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 discirminant |
| -- that are used in iterators. This is an optimization, but it |
| -- also prevents typing anomalies when the prefix is further |
| -- expanded. Limited types with discriminants are included. |
| |
| elsif Is_Limited_Record (Typ) |
| or else |
| (Ekind (Typ) = E_Limited_Private_Type |
| and then Has_Discriminants (Typ) |
| and then Is_Access_Type (Etype (First_Discriminant (Typ)))) |
| 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); |
| |
| -- 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; |
| |
| -- Start of processing for Analyze_Object_Renaming |
| |
| begin |
| if Nam = Error then |
| return; |
| end if; |
| |
| Check_SPARK_05_Restriction ("object renaming is not allowed", N); |
| |
| 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; |
| |
| -- Complete analysis of the subtype mark in any case, for ASIS use |
| |
| if Present (Subtype_Mark (N)) then |
| Find_Type (Subtype_Mark (N)); |
| end if; |
| |
| elsif Present (Subtype_Mark (N)) then |
| Find_Type (Subtype_Mark (N)); |
| T := Entity (Subtype_Mark (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; |
| |
| -- Reject renamings of conversions unless the type is tagged, or |
| -- the conversion is implicit (which can occur for cases of anonymous |
| -- access types in Ada 2012). |
| |
| if Nkind (Nam) = N_Type_Conversion |
| and then Comes_From_Source (Nam) |
| and then not Is_Tagged_Type (T) |
| then |
| Error_Msg_N |
| ("renaming of conversion only allowed for tagged types", Nam); |
| 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); |
| Set_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 Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type |
| and then Ekind (T) /= E_Anonymous_Access_Type |
| then |
| Wrong_Type (Expression (Nam), T); -- Should we give better error??? |
| 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; |
| |
| T2 := Etype (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; |
| |
| -- Ada 2005 (AI-327) |
| |
| if Ada_Version >= Ada_2005 |
| and then Nkind (Nam) = N_Attribute_Reference |
| and then Attribute_Name (Nam) = Name_Priority |
| then |
| null; |
| |
| elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then |
| declare |
| Nam_Decl : Node_Id; |
| Nam_Ent : Entity_Id; |
| |
| begin |
| if Nkind (Nam) = N_Attribute_Reference then |
| Nam_Ent := Entity (Prefix (Nam)); |
| else |
| Nam_Ent := Entity (Nam); |
| end if; |
| |
| Nam_Decl := Parent (Nam_Ent); |
| |
| 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 |
| ("renamed formal 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 |
| ("renamed 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 |
| ("renamed 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 |
| ("renamed 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 |
| Set_Ekind (Id, E_Variable); |
| end if; |
| |
| -- Initialize the object size and alignment. Note that we used to call |
| -- Init_Size_Align here, but that's wrong for objects which have only |
| -- an Esize, not an RM_Size field. |
| |
| Init_Object_Size_Align (Id); |
| |
| if T = Any_Type or else Etype (Nam) = Any_Type then |
| return; |
| |
| -- Verify that the renamed entity is an object or a function call. It |
| -- may have been rewritten in several ways. |
| |
| elsif Is_Object_Reference (Nam) 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; |
| |
| -- A static function call may have been folded into a literal |
| |
| elsif Nkind (Original_Node (Nam)) = N_Function_Call |
| |
| -- When expansion is disabled, attribute reference is not rewritten |
| -- as function call. Otherwise it may be rewritten as a conversion, |
| -- so check original node. |
| |
| or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference |
| and then Is_Function_Attribute_Name |
| (Attribute_Name (Original_Node (Nam)))) |
| |
| -- 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. |
| |
| or else (Is_Entity_Name (Nam) |
| and then Ekind (Entity (Nam)) = E_Enumeration_Literal |
| and then |
| Nkind (Original_Node (Nam)) /= N_Attribute_Reference) |
| |
| or else (Nkind (Nam) = N_Type_Conversion |
| and then Is_Tagged_Type (Entity (Subtype_Mark (Nam)))) |
| then |
| null; |
| |
| elsif Nkind (Nam) = N_Type_Conversion then |
| Error_Msg_N |
| ("renaming of conversion only allowed for tagged types", Nam); |
| |
| -- Ada 2005 (AI-327) |
| |
| elsif Ada_Version >= Ada_2005 |
| and then Nkind (Nam) = N_Attribute_Reference |
| and then Attribute_Name (Nam) = Name_Priority |
| then |
| null; |
| |
| -- Allow internally generated x'Ref resulting in N_Reference node |
| |
| elsif Nkind (Nam) = N_Reference then |
| null; |
| |
| else |
| Error_Msg_N ("expect object name in renaming", Nam); |
| end if; |
| |
| Set_Etype (Id, T2); |
| |
| if not Is_Variable (Nam) then |
| Set_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 volatile. Is_Volatile is set if the renamed object |
| -- is volatile in the RM legality sense. |
| |
| Set_Is_Volatile (Id, Is_Volatile_Object (Nam)); |
| |
| -- Also copy settings of Atomic/Independent/Volatile_Full_Access |
| |
| if Is_Entity_Name (Nam) then |
| Set_Is_Atomic (Id, Is_Atomic (Entity (Nam))); |
| Set_Is_Independent (Id, Is_Independent (Entity (Nam))); |
| Set_Is_Volatile_Full_Access (Id, |
| Is_Volatile_Full_Access (Entity (Nam))); |
| end if; |
| |
| -- 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 unit (we may be renaming a Text_IO child) |
| |
| Check_Text_IO_Special_Unit (Name (N)); |
| |
| 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 |
| |
| Set_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. |
| |
| Set_Ekind (New_P, E_Package); |
| Set_Etype (New_P, Standard_Void_Type); |
| |
| if Present (Renamed_Object (Old_P)) then |
| Set_Renamed_Object (New_P, Renamed_Object (Old_P)); |
| else |
| Set_Renamed_Object (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. |
| |
| 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 Ekind (Scope (Old_S)) in Protected_Kind |
| 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; |
| |
| 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; |
| |
| -- 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 Build_Class_Wide_Wrapper |
| (Ren_Id : out Entity_Id; |
| Wrap_Id : out Entity_Id); |
| -- 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, Wrap_Id is the entity of the generated class-wide wrapper |
| -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide |
| -- operation. |
| |
| 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 is a renaming of a formal subprogram and one of its |
| -- parameters has a null exclusion, then the corresponding formal |
| -- in Sub must also have one. Otherwise the subtype of the Sub's |
| -- formal parameter must exclude null. |
| -- |
| -- If Ren is a renaming of a formal function and its return |
| -- profile has a null exclusion, then Sub's return profile must |
| -- have one. Otherwise the subtype of Sub's return profile must |
| -- exclude null. |
| |
| 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): True if N is the renaming for a |
| -- defaulted formal subprogram where the actual for the controlling |
| -- formal type is class-wide. |
| |
| 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). |
| |
| ------------------------------ |
| -- Build_Class_Wide_Wrapper -- |
| ------------------------------ |
| |
| procedure Build_Class_Wide_Wrapper |
| (Ren_Id : out 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. Return |
| -- directly the call, so that it can be used inside an expression |
| -- function. This is a specificity of the GNATprove mode. |
| |
| function Build_Spec (Subp_Id : Entity_Id) return Node_Id; |
| -- Create a subprogram specification based on the subprogram profile |
| -- of Subp_Id. |
| |
| 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. |
| |
| ---------------- |
| -- 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_In (Subp_Id, 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_In (Subp_Id, 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, |
| Chars => 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; |
| |
| -------------------- |
| -- 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 which 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 resolion 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) which 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) which corresponds to the |
| -- renamed generic formal subprogram. |
| |
| Root_Typ : Entity_Id := Empty; |
| -- The root type of Actual_Typ |
| |
| Body_Decl : Node_Id; |
| Formal : Node_Id; |
| Prim_Op : Entity_Id; |
| Spec_Decl : Node_Id; |
| New_Spec : Node_Id; |
| |
| -- Start of processing for Build_Class_Wide_Wrapper |
| |
| begin |
| -- Analyze the specification of the renaming in case the generation |
| -- of the class-wide wrapper fails. |
| |
| Ren_Id := Analyze_Subprogram_Specification (Spec); |
| Wrap_Id := Any_Id; |
| |
| -- Do not attempt to build a wrapper if the renaming is in error |
| |
| if Error_Posted (Nam) then |
| return; |
| end if; |
| |
| -- 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 with unknown discriminants |
| -- 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 := Get_Instance_Of (Formal_Typ); |
| Root_Typ := Etype (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 routine |
| -- Has_Class_Wide_Actual. |
| |
| pragma Assert (Present (Formal_Typ)); |
| |
| -- Step 2: Find the proper class-wide subprogram or primitive which |
| -- 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 which 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; |
| |
| elsif CW_Prim_Op = Root_Prim_Op then |
| Prim_Op := Root_Prim_Op; |
| |
| -- 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; |
| |
| 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); |
| |
| -- Do not generate a wrapper when the only candidate is a class-wide |
| -- subprogram. Instead modify the renaming to directly map the actual |
| -- to the generic formal. |
| |
| if CW_Prim_OK and then Prim_Op = CW_Prim_Op then |
| Wrap_Id := Prim_Op; |
| Rewrite (Nam, New_Occurrence_Of (Prim_Op, Loc)); |
| return; |
| end if; |
| |
| -- Step 3: 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_In (Ren_Id, 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; |
| |
| -- If the operator carries an Eliminated pragma, indicate that the |
| -- wrapper is also to be eliminated, to prevent spurious error when |
| -- using gnatelim on programs that include box-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 4: The subprogram renaming aliases the wrapper |
| |
| Rewrite (Nam, New_Occurrence_Of (Wrap_Id, Loc)); |
| end Build_Class_Wide_Wrapper; |
| |
| -------------------------- |
| -- Check_Null_Exclusion -- |
| -------------------------- |
| |
| procedure Check_Null_Exclusion |
| (Ren : Entity_Id; |
| Sub : Entity_Id) |
| is |
| Ren_Formal : Entity_Id; |
| Sub_Formal : Entity_Id; |
| |
| begin |
| -- Parameter check |
| |
| Ren_Formal := First_Formal (Ren); |
| Sub_Formal := First_Formal (Sub); |
| while Present (Ren_Formal) and then Present (Sub_Formal) loop |
| if Has_Null_Exclusion (Parent (Ren_Formal)) |
| and then |
| not (Has_Null_Exclusion (Parent (Sub_Formal)) |
| or else Can_Never_Be_Null (Etype (Sub_Formal))) |
| then |
| Error_Msg_NE |
| ("`NOT NULL` required for parameter &", |
| Parent (Sub_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 Has_Null_Exclusion (Parent (Ren)) |
| and then not (Has_Null_Exclusion (Parent (Sub)) |
| or else Can_Never_Be_Null (Etype (Sub))) |
| then |
| Error_Msg_N |
| ("return must specify `NOT NULL`", |
| Result_Definition (Parent (Sub))); |
| 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; |
| |
| F := 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; |
| |
| F := 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; |
| |
| ------------------------- |
| -- 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): 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; |
| |
| -- 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 attribute as the name of the |
| -- corresponding stream primitive of the type. |
| |
| -- In a generic context the stream 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)); |
| Stream_Prim : Entity_Id; |
| |
| begin |
| -- The class-wide forms of the stream attributes are not |
| -- primitive dispatching operations (even though they |
| -- internally dispatch to a stream attribute). |
| |
| 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 => |
| Stream_Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); |
| |
| when Name_Output => |
| Stream_Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); |
| |
| when Name_Read => |
| Stream_Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); |
| |
| when Name_Write => |
| Stream_Prim := |
| Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); |
| |
| when others => |
| Error_Msg_N |
| ("attribute must be a primitive dispatching operation", |
| Nam); |
| return; |
| end case; |
| |
| -- If no operation was found, and the type is limited, the user |
| -- should have defined one. |
| |
| if No (Stream_Prim) 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 (Stream_Prim)); |
| begin |
| Set_Entity (Prim_Name, Stream_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); |
| |
| -- Check whether the renaming is for a defaulted actual subprogram |
| -- with a class-wide actual. |
| |
| -- The class-wide wrapper is not needed in GNATprove_Mode and there |
| -- is an external axiomatization on the package. |
| |
| if CW_Actual |
| and then Box_Present (Inst_Node) |
| and then not |
| (GNATprove_Mode |
| and then |
| Present (Containing_Package_With_Ext_Axioms (Formal_Spec))) |
| then |
| Build_Class_Wide_Wrapper (New_S, Old_S); |
| |
| 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_N ("renaming completes a No_Return procedure", N); |
| Error_Msg_N |
| ("\renamed procedure must be nonreturning (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. |
| |
| Set_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)) then |
| Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec); |
| 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 completely 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 not Ekind_In (Old_S, 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); |
| 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; |
| elsif not Is_Actual or else No (Enclosing_Instance) then |
| Check_Mode_Conformant (New_S, Old_S); |
| end if; |
| |
| if Is_Actual and then Error_Posted (New_S) then |
| Error_Msg_NE ("invalid actual subprogram: & #!", N, 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. |
| |
| if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) 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 |
| Error_Msg_NE |
| ("actual must be dispatching subprogram for type&", |
| Nam, New_S_Ctrl_Type); |
| |
| 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; |
| 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); |
| |
| -- An abstract subprogram is only allowed as an actual in the case |
| -- where the formal subprogram is also abstract. |
| |
| if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function) |
| and then Is_Abstract_Subprogram (Old_S) |
| and then not Is_Abstract_Subprogram (Formal_Spec) |
| then |
| Error_Msg_N |
| ("abstract subprogram not allowed as generic actual", Nam); |
| 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; |
| |
| Ada_Version := Save_AV; |
| Ada_Version_Pragma := Save_AVP; |
| Ada_Version_Explicit := Save_AV_Exp; |
| |
| -- In GNATprove mode, the renamings of actual subprograms are replaced |
| -- with wrapper functions that make it easier to propagate axioms to the |
| -- points of call within an instance. Wrappers are generated if formal |
| -- subprogram is subject to axiomatization. |
| |
| -- The types in the wrapper profiles are obtained from (instances of) |
| -- the types of the formal subprogram. |
| |
| if Is_Actual |
| and then GNATprove_Mode |
| and then Present (Containing_Package_With_Ext_Axioms (Formal_Spec)) |
| and then not Inside_A_Generic |
| then |
| if Ekind (Old_S) = E_Function then |
| Rewrite (N, Build_Function_Wrapper (Formal_Spec, Old_S)); |
| Analyze (N); |
| |
| elsif Ekind (Old_S) = E_Operator then |
| Rewrite (N, Build_Operator_Wrapper (Formal_Spec, Old_S)); |
| Analyze (N); |
| end if; |
| end if; |
| |
| -- 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) |
| then |
| Mark_Use_Clauses (New_S); |
| |
| -- Handle overloaded subprograms |
| |
| if Present (Alias (New_S)) then |
| Mark_Use_Clauses (Alias (New_S)); |
| end if; |
| end if; |
| end Analyze_Subprogram_Renaming; |
| |
| ------------------------- |
| -- Analyze_Use_Package -- |
| ------------------------- |
| |
| -- Resolve the package names in the use clause, and make all the visible |
| -- entities defined in the package potentially use-visible. If the package |
| -- is already in use from a previous use clause, its visible entities are |
| -- already use-visible. In that case, mark the occurrence as a redundant |
| -- use. If the package is an open scope, i.e. if the use clause occurs |
| -- within the package itself, ignore it. |
| |
| procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is |
| procedure Analyze_Package_Name (Clause : Node_Id); |
| -- Perform analysis on a package name from a use_package_clause |
| |
| procedure Analyze_Package_Name_List (Head_Clause : Node_Id); |
| -- Similar to Analyze_Package_Name but iterates over all the names |
| -- in a use clause. |
| |
| -------------------------- |
| -- Analyze_Package_Name -- |
| -------------------------- |
| |
| procedure Analyze_Package_Name (Clause : Node_Id) is |
| Pack : constant Node_Id := Name (Clause); |
| Pref : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (Clause) = N_Use_Package_Clause); |
| Analyze (Pack); |
| |
| -- Verify that the package standard is not directly named in a |
| -- use_package_clause. |
| |
| if Nkind (Parent (Clause)) = N_Compilation_Unit |
| and then Nkind (Pack) = N_Expanded_Name |
| then |
| Pref := Prefix (Pack); |
| |
| while Nkind (Pref) = N_Expanded_Name loop |
| Pref := Prefix (Pref); |
| end loop; |
| |
| if Entity (Pref) = Standard_Standard then |
| Error_Msg_N |
| ("predefined package Standard cannot appear in a context " |
| & "clause", Pref); |
| end if; |
| end if; |
| end Analyze_Package_Name; |
| |
| ------------------------------- |
| -- Analyze_Package_Name_List -- |
| ------------------------------- |
| |
| procedure Analyze_Package_Name_List (Head_Clause : Node_Id) is |
| Curr : Node_Id; |
| |
| begin |
| -- Due to the way source use clauses are split during parsing we are |
| -- forced to simply iterate through all entities in scope until the |
| -- clause representing the last name in the list is found. |
| |
| Curr := Head_Clause; |
| while Present (Curr) loop |
| Analyze_Package_Name (Curr); |
| |
| -- Stop iterating over the names in the use clause when we are at |
| -- the last one. |
| |
| exit when not More_Ids (Curr) and then Prev_Ids (Curr); |
| Next (Curr); |
| end loop; |
| end Analyze_Package_Name_List; |
| |
| -- Local variables |
| |
| Pack : Entity_Id; |
| |
| -- Start of processing for Analyze_Use_Package |
| |
| begin |
| Check_SPARK_05_Restriction ("use clause is not allowed", N); |
| |
| Set_Hidden_By_Use_Clause (N, No_Elist); |
| |
| -- Use clause not allowed in a spec of a predefined package declaration |
| -- except that packages whose file name starts a-n are OK (these are |
| -- children of Ada.Numerics, which are never loaded by Rtsfind). |
| |
| if Is_Predefined_Unit (Current_Sem_Unit) |
| and then Get_Name_String |
| (Unit_File_Name (Current_Sem_Unit)) (1 .. 3) /= "a-n" |
| and then Nkind (Unit (Cunit (Current_Sem_Unit))) = |
| N_Package_Declaration |
| then |
| Error_Msg_N ("use clause not allowed in predefined spec", N); |
| end if; |
| |
| -- Loop through all package names from the original use clause in |
| -- order to analyze referenced packages. A use_package_clause with only |
| -- one name does not have More_Ids or Prev_Ids set, while a clause with |
| -- More_Ids only starts the chain produced by the parser. |
| |
| if not More_Ids (N) and then not Prev_Ids (N) then |
| Analyze_Package_Name (N); |
| |
| elsif More_Ids (N) and then not Prev_Ids (N) then |
| Analyze_Package_Name_List (N); |
| end if; |
| |
| if not Is_Entity_Name (Name (N)) then |
| Error_Msg_N ("& is not a package", Name (N)); |
| |
| return; |
| end if; |
| |
| if Chain then |
| Chain_Use_Clause (N); |
| end if; |
| |
| Pack := Entity (Name (N)); |
| |
| -- There are many cases where scopes are manipulated during analysis, so |
| -- check that Pack's current use clause has not already been chained |
| -- before setting its previous use clause. |
| |
| if Ekind (Pack) = E_Package |
| and then Present (Current_Use_Clause (Pack)) |
| and then Current_Use_Clause (Pack) /= N |
| and then No (Prev_Use_Clause (N)) |
| and then Prev_Use_Clause (Current_Use_Clause (Pack)) /= N |
| then |
| Set_Prev_Use_Clause (N, Current_Use_Clause (Pack)); |
| end if; |
| |
| -- Mark all entities as potentially use visible. |
| |
| if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then |
| if Ekind (Pack) = E_Generic_Package then |
| Error_Msg_N -- CODEFIX |
| ("a generic package is not allowed in a use clause", Name (N)); |
| |
| elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package) |
| then |
| Error_Msg_N -- CODEFIX |
| ("a generic subprogram is not allowed in a use clause", |
| Name (N)); |
| |
| elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then |
| Error_Msg_N -- CODEFIX |
| ("a subprogram is not allowed in a use clause", Name (N)); |
| |
| else |
| Error_Msg_N ("& is not allowed in a use clause", Name (N)); |
| end if; |
| |
| else |
| if Nkind (Parent (N)) = N_Compilation_Unit then |
| Check_In_Previous_With_Clause (N, Name (N)); |
| end if; |
| |
| Use_One_Package (N, Name (N)); |
| end if; |
| |
| Mark_Ghost_Clause (N); |
| end Analyze_Use_Package; |
| |
| ---------------------- |
| -- Analyze_Use_Type -- |
| ---------------------- |
| |
| procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True) is |
| E : Entity_Id; |
| Id : Node_Id; |
| |
| begin |
| Set_Hidden_By_Use_Clause (N, No_Elist); |
| |
| -- Chain clause to list of use clauses in current scope when flagged |
| |
| if Chain then |
| Chain_Use_Clause (N); |
| end if; |
| |
| -- Obtain the base type of the type denoted within the use_type_clause's |
| -- subtype mark. |
| |
| Id := Subtype_Mark (N); |
| Find_Type (Id); |
| E := Base_Type (Entity (Id)); |
| |
| -- There are many cases where a use_type_clause may be reanalyzed due to |
| -- manipulation of the scope stack so we much guard against those cases |
| -- here, otherwise, we must add the new use_type_clause to the previous |
| -- use_type_clause chain in order to mark redundant use_type_clauses as |
| -- used. When the redundant use-type clauses appear in a parent unit and |
| -- a child unit we must prevent a circularity in the chain that would |
| -- otherwise result from the separate steps of analysis and installation |
| -- of the parent context. |
| |
| if Present (Current_Use_Clause (E)) |
| and then Current_Use_Clause (E) /= N |
| and then Prev_Use_Clause (Current_Use_Clause (E)) /= N |
| and then No (Prev_Use_Clause (N)) |
| then |
| Set_Prev_Use_Clause (N, Current_Use_Clause (E)); |
| end if; |
| |
| -- If the Used_Operations list is already initialized, the clause has |
| -- been analyzed previously, and it is being reinstalled, for example |
| -- when the clause appears in a package spec and we are compiling the |
| -- corresponding package body. In that case, make the entities on the |
| -- existing list use_visible, and mark the corresponding types In_Use. |
| |
| if Present (Used_Operations (N)) then |
| declare |
| Elmt : Elmt_Id; |
| |
| begin |
| Use_One_Type (Subtype_Mark (N), Installed => True); |
| |
| Elmt := First_Elmt (Used_Operations (N)); |
| while Present (Elmt) loop |
| Set_Is_Potentially_Use_Visible (Node (Elmt)); |
| Next_Elmt (Elmt); |
| end loop; |
| end; |
| |
| return; |
| end if; |
| |
| -- Otherwise, create new list and attach to it the operations that are |
| -- made use-visible by the clause. |
| |
| Set_Used_Operations (N, New_Elmt_List); |
| E := Entity (Id); |
| |
| if E /= Any_Type then |
| Use_One_Type (Id); |
| |
| if Nkind (Parent (N)) = N_Compilation_Unit then |
| if Nkind (Id) = N_Identifier then |
| Error_Msg_N ("type is not directly visible", Id); |
| |
| elsif Is_Child_Unit (Scope (E)) |
| and then Scope (E) /= System_Aux_Id |
| then |
| Check_In_Previous_With_Clause (N, Prefix (Id)); |
| end if; |
| end if; |
| |
| else |
| -- If the use_type_clause appears in a compilation unit context, |
| -- check whether it comes from a unit that may appear in a |
| -- limited_with_clause, for a better error message. |
| |
| if Nkind (Parent (N)) = N_Compilation_Unit |
| and then Nkind (Id) /= N_Identifier |
| then |
| declare |
| Item : Node_Id; |
| Pref : Node_Id; |
| |
| function Mentioned (Nam : Node_Id) return Boolean; |
| -- Check whether the prefix of expanded name for the type |
| -- appears in the prefix of some limited_with_clause. |
| |
| --------------- |
| -- Mentioned -- |
| --------------- |
| |
| function Mentioned (Nam : Node_Id) return Boolean is |
| begin |
| return Nkind (Name (Item)) = N_Selected_Component |
| and then Chars (Prefix (Name (Item))) = Chars (Nam); |
| end Mentioned; |
| |
| begin |
| Pref := Prefix (Id); |
| Item := First (Context_Items (Parent (N))); |
| while Present (Item) and then Item /= N loop |
| if Nkind (Item) = N_With_Clause |
| and then Limited_Present (Item) |
| and then Mentioned (Pref) |
| then |
| Change_Error_Text |
| (Get_Msg_Id, "premature usage of incomplete type"); |
| end if; |
| |
| Next (Item); |
| end loop; |
| end; |
| end if; |
| end if; |
| |
| Mark_Ghost_Clause (N); |
| end Analyze_Use_Type; |
| |
| ------------------------ |
| -- Attribute_Renaming -- |
| ------------------------ |
| |
| procedure Attribute_Renaming (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Nam : constant Node_Id := Name (N); |
| Spec : constant Node_Id := Specification (N); |
| New_S : constant Entity_Id := Defining_Unit_Name (Spec); |
| Aname : constant Name_Id := Attribute_Name (Nam); |
| |
| Form_Num : Nat := 0; |
| Expr_List : List_Id := No_List; |
| |
| Attr_Node : Node_Id; |
| Body_Node : Node_Id; |
| Param_Spec : Node_Id; |
| |
| begin |
| Generate_Definition (New_S); |
| |
| -- This procedure is called in the context of subprogram renaming, and |
| -- thus the attribute must be one that is a subprogram. All of those |
| -- have at least one formal parameter, with the exceptions of the GNAT |
| -- attribute 'Img, which GNAT treats as renameable. |
| |
| if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then |
| if Aname /= Name_Img then |
| Error_Msg_N |
| ("subprogram renaming an attribute must have formals", N); |
| return; |
| end if; |
| |
| else |
| Param_Spec := First (Parameter_Specifications (Spec)); |
| while Present (Param_Spec) loop |
| Form_Num := Form_Num + 1; |
| |
| if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then |
| Find_Type (Parameter_Type (Param_Spec)); |
| |
| -- The profile of the new entity denotes the base type (s) of |
| -- the types given in the specification. For access parameters |
| -- there are no subtypes involved. |
| |
| Rewrite (Parameter_Type (Param_Spec), |
| New_Occurrence_Of |
| (Base_Type (Entity (Parameter_Type (Param_Spec))), Loc)); |
| end if; |
| |
| if No (Expr_List) then |
| Expr_List := New_List; |
| end if; |
| |
| Append_To (Expr_List, |
| Make_Identifier (Loc, |
| Chars => Chars (Defining_Identifier (Param_Spec)))); |
| |
| -- The expressions in the attribute reference are not freeze |
| -- points. Neither is the attribute as a whole, see below. |
| |
| Set_Must_Not_Freeze (Last (Expr_List)); |
| Next (Param_Spec); |
| end loop; |
| end if; |
| |
| -- Immediate error if too many formals. Other mismatches in number or |
| -- types of parameters are detected when we analyze the body of the |
| -- subprogram that we construct. |
| |
| if Form_Num > 2 then |
| Error_Msg_N ("too many formals for attribute", N); |
| |
| -- Error if the attribute reference has expressions that look like |
| -- formal parameters. |
| |
| elsif Present (Expressions (Nam)) then |
| Error_Msg_N ("illegal expressions in attribute reference", Nam); |
| |
| elsif |
| Nam_In (Aname, Name_Compose, Name_Exponent, Name_Leading_Part, |
| Name_Pos, Name_Round, Name_Scaling, |
| Name_Val) |
| then |
| if Nkind (N) = N_Subprogram_Renaming_Declaration |
| and then Present (Corresponding_Formal_Spec (N)) |
| then |
| Error_Msg_N |
| ("generic actual cannot be attribute involving universal type", |
| Nam); |
| else |
| Error_Msg_N |
| ("attribute involving a universal type cannot be renamed", |
| Nam); |
| end if; |
| end if; |
| |
| -- Rewrite attribute node to have a list of expressions corresponding to |
| -- the subprogram formals. A renaming declaration is not a freeze point, |
| -- and the analysis of the attribute reference should not freeze the |
| -- type of the prefix. We use the original node in the renaming so that |
| -- its source location is preserved, and checks on stream attributes are |
| -- properly applied. |
| |
| Attr_Node := Relocate_Node (Nam); |
| Set_Expressions (Attr_Node, Expr_List); |
| |
| Set_Must_Not_Freeze (Attr_Node); |
| Set_Must_Not_Freeze (Prefix (Nam)); |
| |
| -- Case of renaming a function |
| |
| if Nkind (Spec) = N_Function_Specification then |
| if Is_Procedure_Attribute_Name (Aname) then |
| Error_Msg_N ("attribute can only be renamed as procedure", Nam); |
| return; |
| end if; |
| |
| Find_Type (Result_Definition (Spec)); |
| Rewrite (Result_Definition (Spec), |
| New_Occurrence_Of |
| (Base_Type (Entity (Result_Definition (Spec))), Loc)); |
| |
| Body_Node := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Make_Simple_Return_Statement (Loc, |
| Expression => Attr_Node)))); |
| |
| -- Case of renaming a procedure |
| |
| else |
| if not Is_Procedure_Attribute_Name (Aname) then |
| Error_Msg_N ("attribute can only be renamed as function", Nam); |
| return; |
| end if; |
| |
| Body_Node := |
| Make_Subprogram_Body (Loc, |
| Specification => Spec, |
| Declarations => New_List, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Attr_Node))); |
| end if; |
| |
| -- Signal the ABE mechanism that the generated subprogram body has not |
| -- ABE ramifications. |
| |
| Set_Was_Attribute_Reference (Body_Node); |
| |
| -- In case of tagged types we add the body of the generated function to |
| -- the freezing actions of the type (because in the general case such |
| -- type is still not frozen). We exclude from this processing generic |
| -- formal subprograms found in instantiations. |
| |
| -- We must exclude restricted run-time libraries because |
| -- entity AST_Handler is defined in package System.Aux_Dec which is not |
| -- available in those platforms. Note that we cannot use the function |
| -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because |
| -- the ZFP run-time library is not defined as a profile, and we do not |
| -- want to deal with AST_Handler in ZFP mode. |
| |
| if not Configurable_Run_Time_Mode |
| and then not Present (Corresponding_Formal_Spec (N)) |
| and then Etype (Nam) /= RTE (RE_AST_Handler) |
| then |
| declare |
| P : constant Node_Id := Prefix (Nam); |
| |
| begin |
| -- The prefix of 'Img is an object that is evaluated for each call |
| -- of the function that renames it. |
| |
| if Aname = Name_Img then |
| Preanalyze_And_Resolve (P); |
| |
| -- For all other attribute renamings, the prefix is a subtype |
| |
| else |
| Find_Type (P); |
| end if; |
| |
| -- If the target type is not yet frozen, add the body to the |
| -- actions to be elaborated at freeze time. |
| |
| if Is_Tagged_Type (Etype (P)) |
| and then In_Open_Scopes (Scope (Etype (P))) |
| then |
| Ensure_Freeze_Node (Etype (P)); |
| Append_Freeze_Action (Etype (P), Body_Node); |
| else |
| Rewrite (N, Body_Node); |
| Analyze (N); |
| Set_Etype (New_S, Base_Type (Etype (New_S))); |
| end if; |
| end; |
| |
| -- Generic formal subprograms or AST_Handler renaming |
| |
| else |
| Rewrite (N, Body_Node); |
| Analyze (N); |
| Set_Etype (New_S, Base_Type (Etype (New_S))); |
| end if; |
| |
| if Is_Compilation_Unit (New_S) then |
| Error_Msg_N |
| ("a library unit can only rename another library unit", N); |
| end if; |
| |
| -- We suppress elaboration warnings for the resulting entity, since |
| -- clearly they are not needed, and more particularly, in the case |
| -- of a generic formal subprogram, the resulting entity can appear |
| -- after the instantiation itself, and thus look like a bogus case |
| -- of access before elaboration. |
| |
| if Legacy_Elaboration_Checks then |
| Set_Suppress_Elaboration_Warnings (New_S); |
| end if; |
| end Attribute_Renaming; |
| |
| ---------------------- |
| -- Chain_Use_Clause -- |
| ---------------------- |
| |
| procedure Chain_Use_Clause (N : Node_Id) is |
| Level : Int := Scope_Stack.Last; |
| Pack : Entity_Id; |
| |
| begin |
| -- Common case |
| |
|