| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 3 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Aspects; use Aspects; |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Contracts; use Contracts; |
| with Debug; use Debug; |
| with Elists; use Elists; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Errout; use Errout; |
| with Eval_Fat; use Eval_Fat; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_Ch9; use Exp_Ch9; |
| with Exp_Disp; use Exp_Disp; |
| with Exp_Dist; use Exp_Dist; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Expander; use Expander; |
| with Freeze; use Freeze; |
| with Ghost; use Ghost; |
| with Itypes; use Itypes; |
| with Layout; use Layout; |
| with Lib; use Lib; |
| with Lib.Xref; use Lib.Xref; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Case; use Sem_Case; |
| with Sem_Cat; use Sem_Cat; |
| with Sem_Ch6; use Sem_Ch6; |
| with Sem_Ch7; use Sem_Ch7; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Ch10; use Sem_Ch10; |
| 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_Elim; use Sem_Elim; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Mech; use Sem_Mech; |
| with Sem_Res; use Sem_Res; |
| with Sem_Smem; use Sem_Smem; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sem_Warn; use Sem_Warn; |
| with Stand; use Stand; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Sinput; use Sinput; |
| with Snames; use Snames; |
| with Strub; use Strub; |
| with Targparm; use Targparm; |
| with Tbuild; use Tbuild; |
| with Ttypes; use Ttypes; |
| with Uintp; use Uintp; |
| with Urealp; use Urealp; |
| with Warnsw; use Warnsw; |
| |
| package body Sem_Ch3 is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id); |
| -- Ada 2005 (AI-251): Add the tag components corresponding to all the |
| -- abstract interface types implemented by a record type or a derived |
| -- record type. |
| |
| procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id); |
| -- When an access-to-subprogram type has pre/postconditions, we build a |
| -- subprogram that includes these contracts and is invoked by an indirect |
| -- call through the corresponding access type. |
| |
| procedure Build_Derived_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id; |
| Is_Completion : Boolean; |
| Derive_Subps : Boolean := True); |
| -- Create and decorate a Derived_Type given the Parent_Type entity. N is |
| -- the N_Full_Type_Declaration node containing the derived type definition. |
| -- Parent_Type is the entity for the parent type in the derived type |
| -- definition and Derived_Type the actual derived type. Is_Completion must |
| -- be set to False if Derived_Type is the N_Defining_Identifier node in N |
| -- (i.e. Derived_Type = Defining_Identifier (N)). In this case N is not the |
| -- completion of a private type declaration. If Is_Completion is set to |
| -- True, N is the completion of a private type declaration and Derived_Type |
| -- is different from the defining identifier inside N (i.e. Derived_Type /= |
| -- Defining_Identifier (N)). Derive_Subps indicates whether the parent |
| -- subprograms should be derived. The only case where this parameter is |
| -- False is when Build_Derived_Type is recursively called to process an |
| -- implicit derived full type for a type derived from a private type (in |
| -- that case the subprograms must only be derived for the private view of |
| -- the type). |
| -- |
| -- ??? These flags need a bit of re-examination and re-documentation: |
| -- ??? are they both necessary (both seem related to the recursion)? |
| |
| procedure Build_Derived_Access_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Type. For a derived access type, |
| -- create an implicit base if the parent type is constrained or if the |
| -- subtype indication has a constraint. |
| |
| procedure Build_Derived_Array_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Type. For a derived array type, |
| -- create an implicit base if the parent type is constrained or if the |
| -- subtype indication has a constraint. |
| |
| procedure Build_Derived_Concurrent_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Type. For a derived task or |
| -- protected type, inherit entries and protected subprograms, check |
| -- legality of discriminant constraints if any. |
| |
| procedure Build_Derived_Enumeration_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Type. For a derived enumeration |
| -- type, we must create a new list of literals. Types derived from |
| -- Character and [Wide_]Wide_Character are special-cased. |
| |
| procedure Build_Derived_Numeric_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Type. For numeric types, create |
| -- an anonymous base type, and propagate constraint to subtype if needed. |
| |
| procedure Build_Derived_Private_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id; |
| Is_Completion : Boolean; |
| Derive_Subps : Boolean := True); |
| -- Subsidiary procedure to Build_Derived_Type. This procedure is complex |
| -- because the parent may or may not have a completion, and the derivation |
| -- may itself be a completion. |
| |
| procedure Build_Derived_Record_Type |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id; |
| Derive_Subps : Boolean := True); |
| -- Subsidiary procedure used for tagged and untagged record types |
| -- by Build_Derived_Type and Analyze_Private_Extension_Declaration. |
| -- All parameters are as in Build_Derived_Type except that N, in |
| -- addition to being an N_Full_Type_Declaration node, can also be an |
| -- N_Private_Extension_Declaration node. See the definition of this routine |
| -- for much more info. Derive_Subps indicates whether subprograms should be |
| -- derived from the parent type. The only case where Derive_Subps is False |
| -- is for an implicit derived full type for a type derived from a private |
| -- type (see Build_Derived_Type). |
| |
| procedure Build_Discriminal (Discrim : Entity_Id); |
| -- Create the discriminal corresponding to discriminant Discrim, that is |
| -- the parameter corresponding to Discrim to be used in initialization |
| -- procedures for the type where Discrim is a discriminant. Discriminals |
| -- are not used during semantic analysis, and are not fully defined |
| -- entities until expansion. Thus they are not given a scope until |
| -- initialization procedures are built. |
| |
| function Build_Discriminant_Constraints |
| (T : Entity_Id; |
| Def : Node_Id; |
| Derived_Def : Boolean := False) return Elist_Id; |
| -- Validate discriminant constraints and return the list of the constraints |
| -- in order of discriminant declarations, where T is the discriminated |
| -- unconstrained type. Def is the N_Subtype_Indication node where the |
| -- discriminants constraints for T are specified. Derived_Def is True |
| -- when building the discriminant constraints in a derived type definition |
| -- of the form "type D (...) is new T (xxx)". In this case T is the parent |
| -- type and Def is the constraint "(xxx)" on T and this routine sets the |
| -- Corresponding_Discriminant field of the discriminants in the derived |
| -- type D to point to the corresponding discriminants in the parent type T. |
| |
| procedure Build_Discriminated_Subtype |
| (T : Entity_Id; |
| Def_Id : Entity_Id; |
| Elist : Elist_Id; |
| Related_Nod : Node_Id; |
| For_Access : Boolean := False); |
| -- Subsidiary procedure to Constrain_Discriminated_Type and to |
| -- Process_Incomplete_Dependents. Given |
| -- |
| -- T (a possibly discriminated base type) |
| -- Def_Id (a very partially built subtype for T), |
| -- |
| -- the call completes Def_Id to be the appropriate E_*_Subtype. |
| -- |
| -- The Elist is the list of discriminant constraints if any (it is set |
| -- to No_Elist if T is not a discriminated type, and to an empty list if |
| -- T has discriminants but there are no discriminant constraints). The |
| -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. |
| -- The For_Access says whether or not this subtype is really constraining |
| -- an access type. |
| |
| function Build_Scalar_Bound |
| (Bound : Node_Id; |
| Par_T : Entity_Id; |
| Der_T : Entity_Id) return Node_Id; |
| -- The bounds of a derived scalar type are conversions of the bounds of |
| -- the parent type. Optimize the representation if the bounds are literals. |
| -- Needs a more complete spec--what are the parameters exactly, and what |
| -- exactly is the returned value, and how is Bound affected??? |
| |
| procedure Check_Access_Discriminant_Requires_Limited |
| (D : Node_Id; |
| Loc : Node_Id); |
| -- Check the restriction that the type to which an access discriminant |
| -- belongs must be a concurrent type or a descendant of a type with |
| -- the reserved word 'limited' in its declaration. |
| |
| procedure Check_Anonymous_Access_Component |
| (Typ_Decl : Node_Id; |
| Typ : Entity_Id; |
| Prev : Entity_Id; |
| Comp_Def : Node_Id; |
| Access_Def : Node_Id); |
| -- Ada 2005 AI-382: an access component in a record definition can refer to |
| -- the enclosing record, in which case it denotes the type itself, and not |
| -- the current instance of the type. We create an anonymous access type for |
| -- the component, and flag it as an access to a component, so accessibility |
| -- checks are properly performed on it. The declaration of the access type |
| -- is placed ahead of that of the record to prevent order-of-elaboration |
| -- circularity issues in Gigi. We create an incomplete type for the record |
| -- declaration, which is the designated type of the anonymous access. |
| |
| procedure Check_Anonymous_Access_Components |
| (Typ_Decl : Node_Id; |
| Typ : Entity_Id; |
| Prev : Entity_Id; |
| Comp_List : Node_Id); |
| -- Call Check_Anonymous_Access_Component on Comp_List |
| |
| procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id); |
| -- Check that, if a new discriminant is used in a constraint defining the |
| -- parent subtype of a derivation, its subtype is statically compatible |
| -- with the subtype of the corresponding parent discriminant (RM 3.7(15)). |
| |
| procedure Check_Delta_Expression (E : Node_Id); |
| -- Check that the expression represented by E is suitable for use as a |
| -- delta expression, i.e. it is of real type and is static. |
| |
| procedure Check_Digits_Expression (E : Node_Id); |
| -- Check that the expression represented by E is suitable for use as a |
| -- digits expression, i.e. it is of integer type, positive and static. |
| |
| procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); |
| -- Validate the initialization of an object declaration. T is the required |
| -- type, and Exp is the initialization expression. |
| |
| procedure Check_Interfaces (N : Node_Id; Def : Node_Id); |
| -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) |
| |
| procedure Check_Or_Process_Discriminants |
| (N : Node_Id; |
| T : Entity_Id; |
| Prev : Entity_Id := Empty); |
| -- If N is the full declaration of the completion T of an incomplete or |
| -- private type, check its discriminants (which are already known to be |
| -- conformant with those of the partial view, see Find_Type_Name), |
| -- otherwise process them. Prev is the entity of the partial declaration, |
| -- if any. |
| |
| procedure Check_Real_Bound (Bound : Node_Id); |
| -- Check given bound for being of real type and static. If not, post an |
| -- appropriate message, and rewrite the bound with the real literal zero. |
| |
| procedure Constant_Redeclaration |
| (Id : Entity_Id; |
| N : Node_Id; |
| T : out Entity_Id); |
| -- Various checks on legality of full declaration of deferred constant. |
| -- Id is the entity for the redeclaration, N is the N_Object_Declaration, |
| -- node. The caller has not yet set any attributes of this entity. |
| |
| function Contain_Interface |
| (Iface : Entity_Id; |
| Ifaces : Elist_Id) return Boolean; |
| -- Ada 2005: Determine whether Iface is present in the list Ifaces |
| |
| procedure Convert_Scalar_Bounds |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id; |
| Loc : Source_Ptr); |
| -- For derived scalar types, convert the bounds in the type definition to |
| -- the derived type, and complete their analysis. Given a constraint of the |
| -- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with |
| -- T'Base, the parent_type. The bounds of the derived type (the anonymous |
| -- base) are copies of Lo and Hi. Finally, the bounds of the derived |
| -- subtype are conversions of those bounds to the derived_type, so that |
| -- their typing is consistent. |
| |
| procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id); |
| -- Copies attributes from array base type T2 to array base type T1. Copies |
| -- only attributes that apply to base types, but not subtypes. |
| |
| procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id); |
| -- Copies attributes from array subtype T2 to array subtype T1. Copies |
| -- attributes that apply to both subtypes and base types. |
| |
| procedure Create_Constrained_Components |
| (Subt : Entity_Id; |
| Decl_Node : Node_Id; |
| Typ : Entity_Id; |
| Constraints : Elist_Id); |
| -- Build the list of entities for a constrained discriminated record |
| -- subtype. If a component depends on a discriminant, replace its subtype |
| -- using the discriminant values in the discriminant constraint. Subt |
| -- is the defining identifier for the subtype whose list of constrained |
| -- entities we will create. Decl_Node is the type declaration node where |
| -- we will attach all the itypes created. Typ is the base discriminated |
| -- type for the subtype Subt. Constraints is the list of discriminant |
| -- constraints for Typ. |
| |
| function Constrain_Component_Type |
| (Comp : Entity_Id; |
| Constrained_Typ : Entity_Id; |
| Related_Node : Node_Id; |
| Typ : Entity_Id; |
| Constraints : Elist_Id) return Entity_Id; |
| -- Given a discriminated base type Typ, a list of discriminant constraints, |
| -- Constraints, for Typ and a component Comp of Typ, create and return the |
| -- type corresponding to Etype (Comp) where all discriminant references |
| -- are replaced with the corresponding constraint. If Etype (Comp) contains |
| -- no discriminant references then it is returned as-is. Constrained_Typ |
| -- is the final constrained subtype to which the constrained component |
| -- belongs. Related_Node is the node where we attach all created itypes. |
| |
| procedure Constrain_Access |
| (Def_Id : in out Entity_Id; |
| S : Node_Id; |
| Related_Nod : Node_Id); |
| -- Apply a list of constraints to an access type. If Def_Id is empty, it is |
| -- an anonymous type created for a subtype indication. In that case it is |
| -- created in the procedure and attached to Related_Nod. |
| |
| procedure Constrain_Array |
| (Def_Id : in out Entity_Id; |
| SI : Node_Id; |
| Related_Nod : Node_Id; |
| Related_Id : Entity_Id; |
| Suffix : Character); |
| -- Apply a list of index constraints to an unconstrained array type. The |
| -- first parameter is the entity for the resulting subtype. A value of |
| -- Empty for Def_Id indicates that an implicit type must be created, but |
| -- creation is delayed (and must be done by this procedure) because other |
| -- subsidiary implicit types must be created first (which is why Def_Id |
| -- is an in/out parameter). The second parameter is a subtype indication |
| -- node for the constrained array to be created (e.g. something of the |
| -- form string (1 .. 10)). Related_Nod gives the place where this type |
| -- has to be inserted in the tree. The Related_Id and Suffix parameters |
| -- are used to build the associated Implicit type name. |
| |
| procedure Constrain_Concurrent |
| (Def_Id : in out Entity_Id; |
| SI : Node_Id; |
| Related_Nod : Node_Id; |
| Related_Id : Entity_Id; |
| Suffix : Character); |
| -- Apply list of discriminant constraints to an unconstrained concurrent |
| -- type. |
| -- |
| -- SI is the N_Subtype_Indication node containing the constraint and |
| -- the unconstrained type to constrain. |
| -- |
| -- Def_Id is the entity for the resulting constrained subtype. A value |
| -- of Empty for Def_Id indicates that an implicit type must be created, |
| -- but creation is delayed (and must be done by this procedure) because |
| -- other subsidiary implicit types must be created first (which is why |
| -- Def_Id is an in/out parameter). |
| -- |
| -- Related_Nod gives the place where this type has to be inserted |
| -- in the tree. |
| -- |
| -- The last two arguments are used to create its external name if needed. |
| |
| function Constrain_Corresponding_Record |
| (Prot_Subt : Entity_Id; |
| Corr_Rec : Entity_Id; |
| Related_Nod : Node_Id) return Entity_Id; |
| -- When constraining a protected type or task type with discriminants, |
| -- constrain the corresponding record with the same discriminant values. |
| |
| procedure Constrain_Decimal (Def_Id : Entity_Id; S : Node_Id); |
| -- Constrain a decimal fixed point type with a digits constraint and/or a |
| -- range constraint, and build E_Decimal_Fixed_Point_Subtype entity. |
| |
| procedure Constrain_Discriminated_Type |
| (Def_Id : Entity_Id; |
| S : Node_Id; |
| Related_Nod : Node_Id; |
| For_Access : Boolean := False); |
| -- Process discriminant constraints of composite type. Verify that values |
| -- have been provided for all discriminants, that the original type is |
| -- unconstrained, and that the types of the supplied expressions match |
| -- the discriminant types. The first three parameters are like in routine |
| -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation |
| -- of For_Access. |
| |
| procedure Constrain_Enumeration (Def_Id : Entity_Id; S : Node_Id); |
| -- Constrain an enumeration type with a range constraint. This is identical |
| -- to Constrain_Integer, but for the Ekind of the resulting subtype. |
| |
| procedure Constrain_Float (Def_Id : Entity_Id; S : Node_Id); |
| -- Constrain a floating point type with either a digits constraint |
| -- and/or a range constraint, building a E_Floating_Point_Subtype. |
| |
| procedure Constrain_Index |
| (Index : Node_Id; |
| S : Node_Id; |
| Related_Nod : Node_Id; |
| Related_Id : Entity_Id; |
| Suffix : Character; |
| Suffix_Index : Pos); |
| -- Process an index constraint S in a constrained array declaration. The |
| -- constraint can be a subtype name, or a range with or without an explicit |
| -- subtype mark. The index is the corresponding index of the unconstrained |
| -- array. The Related_Id and Suffix parameters are used to build the |
| -- associated Implicit type name. |
| |
| procedure Constrain_Integer (Def_Id : Entity_Id; S : Node_Id); |
| -- Build subtype of a signed or modular integer type |
| |
| procedure Constrain_Ordinary_Fixed (Def_Id : Entity_Id; S : Node_Id); |
| -- Constrain an ordinary fixed point type with a range constraint, and |
| -- build an E_Ordinary_Fixed_Point_Subtype entity. |
| |
| procedure Copy_And_Swap (Priv, Full : Entity_Id); |
| -- Copy the Priv entity into the entity of its full declaration then swap |
| -- the two entities in such a manner that the former private type is now |
| -- seen as a full type. |
| |
| procedure Decimal_Fixed_Point_Type_Declaration |
| (T : Entity_Id; |
| Def : Node_Id); |
| -- Create a new decimal fixed point type, and apply the constraint to |
| -- obtain a subtype of this new type. |
| |
| procedure Complete_Private_Subtype |
| (Priv : Entity_Id; |
| Full : Entity_Id; |
| Full_Base : Entity_Id; |
| Related_Nod : Node_Id); |
| -- Complete the implicit full view of a private subtype by setting the |
| -- appropriate semantic fields. If the full view of the parent is a record |
| -- type, build constrained components of subtype. |
| |
| procedure Derive_Progenitor_Subprograms |
| (Parent_Type : Entity_Id; |
| Tagged_Type : Entity_Id); |
| -- Ada 2005 (AI-251): To complete type derivation, collect the primitive |
| -- operations of progenitors of Tagged_Type, and replace the subsidiary |
| -- subtypes with Tagged_Type, to build the specs of the inherited interface |
| -- primitives. The derived primitives are aliased to those of the |
| -- interface. This routine takes care also of transferring to the full view |
| -- subprograms associated with the partial view of Tagged_Type that cover |
| -- interface primitives. |
| |
| procedure Derived_Standard_Character |
| (N : Node_Id; |
| Parent_Type : Entity_Id; |
| Derived_Type : Entity_Id); |
| -- Subsidiary procedure to Build_Derived_Enumeration_Type which handles |
| -- derivations from types Standard.Character and Standard.Wide_Character. |
| |
| procedure Derived_Type_Declaration |
| (T : Entity_Id; |
| N : Node_Id; |
| Is_Completion : Boolean); |
| -- Process a derived type declaration. Build_Derived_Type is invoked |
| -- to process the actual derived type definition. Parameters N and |
| -- Is_Completion have the same meaning as in Build_Derived_Type. |
| -- T is the N_Defining_Identifier for the entity defined in the |
| -- N_Full_Type_Declaration node N, that is T is the derived type. |
| |
| procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); |
| -- Insert each literal in symbol table, as an overloadable identifier. Each |
| -- enumeration type is mapped into a sequence of integers, and each literal |
| -- is defined as a constant with integer value. If any of the literals are |
| -- character literals, the type is a character type, which means that |
| -- strings are legal aggregates for arrays of components of the type. |
| |
| function Expand_To_Stored_Constraint |
| (Typ : Entity_Id; |
| Constraint : Elist_Id) return Elist_Id; |
| -- Given a constraint (i.e. a list of expressions) on the discriminants of |
| -- Typ, expand it into a constraint on the stored discriminants and return |
| -- the new list of expressions constraining the stored discriminants. |
| |
| function Find_Type_Of_Object |
| (Obj_Def : Node_Id; |
| Related_Nod : Node_Id) return Entity_Id; |
| -- Get type entity for object referenced by Obj_Def, attaching the implicit |
| -- types generated to Related_Nod. |
| |
| procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); |
| -- Create a new float and apply the constraint to obtain subtype of it |
| |
| function Has_Range_Constraint (N : Node_Id) return Boolean; |
| -- Given an N_Subtype_Indication node N, return True if a range constraint |
| -- is present, either directly, or as part of a digits or delta constraint. |
| -- In addition, a digits constraint in the decimal case returns True, since |
| -- it establishes a default range if no explicit range is present. |
| |
| function Inherit_Components |
| (N : Node_Id; |
| Parent_Base : Entity_Id; |
| Derived_Base : Entity_Id; |
| Is_Tagged : Boolean; |
| Inherit_Discr : Boolean; |
| Discs : Elist_Id) return Elist_Id; |
| -- Called from Build_Derived_Record_Type to inherit the components of |
| -- Parent_Base (a base type) into the Derived_Base (the derived base type). |
| -- For more information on derived types and component inheritance please |
| -- consult the comment above the body of Build_Derived_Record_Type. |
| -- |
| -- N is the original derived type declaration |
| -- |
| -- Is_Tagged is set if we are dealing with tagged types |
| -- |
| -- If Inherit_Discr is set, Derived_Base inherits its discriminants from |
| -- Parent_Base, otherwise no discriminants are inherited. |
| -- |
| -- Discs gives the list of constraints that apply to Parent_Base in the |
| -- derived type declaration. If Discs is set to No_Elist, then we have |
| -- the following situation: |
| -- |
| -- type Parent (D1..Dn : ..) is [tagged] record ...; |
| -- type Derived is new Parent [with ...]; |
| -- |
| -- which gets treated as |
| -- |
| -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...]; |
| -- |
| -- For untagged types the returned value is an association list. The list |
| -- starts from the association (Parent_Base => Derived_Base), and then it |
| -- contains a sequence of the associations of the form |
| -- |
| -- (Old_Component => New_Component), |
| -- |
| -- where Old_Component is the Entity_Id of a component in Parent_Base and |
| -- New_Component is the Entity_Id of the corresponding component in |
| -- Derived_Base. For untagged records, this association list is needed when |
| -- copying the record declaration for the derived base. In the tagged case |
| -- the value returned is irrelevant. |
| |
| function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; |
| -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. |
| -- Determine whether subprogram Subp is a procedure subject to pragma |
| -- Extensions_Visible with value False and has at least one controlling |
| -- parameter of mode OUT. |
| |
| function Is_Private_Primitive (Prim : Entity_Id) return Boolean; |
| -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. |
| -- When applied to a primitive subprogram Prim, returns True if Prim is |
| -- declared as a private operation within a package or generic package, |
| -- and returns False otherwise. |
| |
| function Is_Valid_Constraint_Kind |
| (T_Kind : Type_Kind; |
| Constraint_Kind : Node_Kind) return Boolean; |
| -- Returns True if it is legal to apply the given kind of constraint to the |
| -- given kind of type (index constraint to an array type, for example). |
| |
| procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); |
| -- Create new modular type. Verify that modulus is in bounds |
| |
| procedure New_Concatenation_Op (Typ : Entity_Id); |
| -- Create an abbreviated declaration for an operator in order to |
| -- materialize concatenation on array types. |
| |
| procedure Ordinary_Fixed_Point_Type_Declaration |
| (T : Entity_Id; |
| Def : Node_Id); |
| -- Create a new ordinary fixed point type, and apply the constraint to |
| -- obtain subtype of it. |
| |
| procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); |
| -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that |
| -- In_Default_Expr can be properly adjusted. |
| |
| procedure Prepare_Private_Subtype_Completion |
| (Id : Entity_Id; |
| Related_Nod : Node_Id); |
| -- Id is a subtype of some private type. Creates the full declaration |
| -- associated with Id whenever possible, i.e. when the full declaration |
| -- of the base type is already known. Records each subtype into |
| -- Private_Dependents of the base type. |
| |
| procedure Process_Incomplete_Dependents |
| (N : Node_Id; |
| Full_T : Entity_Id; |
| Inc_T : Entity_Id); |
| -- Process all entities that depend on an incomplete type. There include |
| -- subtypes, subprogram types that mention the incomplete type in their |
| -- profiles, and subprogram with access parameters that designate the |
| -- incomplete type. |
| |
| -- Inc_T is the defining identifier of an incomplete type declaration, its |
| -- Ekind is E_Incomplete_Type. |
| -- |
| -- N is the corresponding N_Full_Type_Declaration for Inc_T. |
| -- |
| -- Full_T is N's defining identifier. |
| -- |
| -- Subtypes of incomplete types with discriminants are completed when the |
| -- parent type is. This is simpler than private subtypes, because they can |
| -- only appear in the same scope, and there is no need to exchange views. |
| -- Similarly, access_to_subprogram types may have a parameter or a return |
| -- type that is an incomplete type, and that must be replaced with the |
| -- full type. |
| -- |
| -- If the full type is tagged, subprogram with access parameters that |
| -- designated the incomplete may be primitive operations of the full type, |
| -- and have to be processed accordingly. |
| |
| procedure Process_Real_Range_Specification (Def : Node_Id); |
| -- Given the type definition for a real type, this procedure processes and |
| -- checks the real range specification of this type definition if one is |
| -- present. If errors are found, error messages are posted, and the |
| -- Real_Range_Specification of Def is reset to Empty. |
| |
| procedure Record_Type_Declaration |
| (T : Entity_Id; |
| N : Node_Id; |
| Prev : Entity_Id); |
| -- Process a record type declaration (for both untagged and tagged |
| -- records). Parameters T and N are exactly like in procedure |
| -- Derived_Type_Declaration, except that no flag Is_Completion is needed |
| -- for this routine. If this is the completion of an incomplete type |
| -- declaration, Prev is the entity of the incomplete declaration, used for |
| -- cross-referencing. Otherwise Prev = T. |
| |
| procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id); |
| -- This routine is used to process the actual record type definition (both |
| -- for untagged and tagged records). Def is a record type definition node. |
| -- This procedure analyzes the components in this record type definition. |
| -- Prev_T is the entity for the enclosing record type. It is provided so |
| -- that its Has_Task flag can be set if any of the component have Has_Task |
| -- set. If the declaration is the completion of an incomplete type |
| -- declaration, Prev_T is the original incomplete type, whose full view is |
| -- the record type. |
| |
| procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id); |
| -- Subsidiary to Build_Derived_Record_Type. For untagged record types, we |
| -- first create the list of components for the derived type from that of |
| -- the parent by means of Inherit_Components and then build a copy of the |
| -- declaration tree of the parent with the help of the mapping returned by |
| -- Inherit_Components, which will for example be used to validate record |
| -- representation clauses given for the derived type. If the parent type |
| -- is private and has discriminants, the ancestor discriminants used in the |
| -- inheritance are that of the private declaration, whereas the ancestor |
| -- discriminants present in the declaration tree of the parent are that of |
| -- the full declaration; as a consequence, the remapping done during the |
| -- copy will leave the references to the ancestor discriminants unchanged |
| -- in the declaration tree and they need to be fixed up. If the derived |
| -- type has a known discriminant part, then the remapping done during the |
| -- copy will only create references to the stored discriminants and they |
| -- need to be replaced with references to the non-stored discriminants. |
| |
| procedure Set_Fixed_Range |
| (E : Entity_Id; |
| Loc : Source_Ptr; |
| Lo : Ureal; |
| Hi : Ureal); |
| -- Build a range node with the given bounds and set it as the Scalar_Range |
| -- of the given fixed-point type entity. Loc is the source location used |
| -- for the constructed range. See body for further details. |
| |
| procedure Set_Scalar_Range_For_Subtype |
| (Def_Id : Entity_Id; |
| R : Node_Id; |
| Subt : Entity_Id); |
| -- This routine is used to set the scalar range field for a subtype given |
| -- Def_Id, the entity for the subtype, and R, the range expression for the |
| -- scalar range. Subt provides the parent subtype to be used to analyze, |
| -- resolve, and check the given range. |
| |
| procedure Set_Default_SSO (T : Entity_Id); |
| -- T is the entity for an array or record being declared. This procedure |
| -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according |
| -- to the setting of Opt.Default_SSO. |
| |
| procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); |
| -- Create a new signed integer entity, and apply the constraint to obtain |
| -- the required first named subtype of this type. |
| |
| procedure Set_Stored_Constraint_From_Discriminant_Constraint |
| (E : Entity_Id); |
| -- E is some record type. This routine computes E's Stored_Constraint |
| -- from its Discriminant_Constraint. |
| |
| procedure Diagnose_Interface (N : Node_Id; E : Entity_Id); |
| -- Check that an entity in a list of progenitors is an interface, |
| -- emit error otherwise. |
| |
| ----------------------- |
| -- Access_Definition -- |
| ----------------------- |
| |
| function Access_Definition |
| (Related_Nod : Node_Id; |
| N : Node_Id) return Entity_Id |
| is |
| Anon_Type : Entity_Id; |
| Anon_Scope : Entity_Id; |
| Desig_Type : Entity_Id; |
| Enclosing_Prot_Type : Entity_Id := Empty; |
| |
| begin |
| if Is_Entry (Current_Scope) |
| and then Is_Task_Type (Etype (Scope (Current_Scope))) |
| then |
| Error_Msg_N ("task entries cannot have access parameters", N); |
| return Empty; |
| end if; |
| |
| -- Ada 2005: For an object declaration the corresponding anonymous |
| -- type is declared in the current scope. |
| |
| -- If the access definition is the return type of another access to |
| -- function, scope is the current one, because it is the one of the |
| -- current type declaration, except for the pathological case below. |
| |
| if Nkind (Related_Nod) in |
| N_Object_Declaration | N_Access_Function_Definition |
| then |
| Anon_Scope := Current_Scope; |
| |
| -- A pathological case: function returning access functions that |
| -- return access functions, etc. Each anonymous access type created |
| -- is in the enclosing scope of the outermost function. |
| |
| declare |
| Par : Node_Id; |
| |
| begin |
| Par := Related_Nod; |
| while Nkind (Par) in |
| N_Access_Function_Definition | N_Access_Definition |
| loop |
| Par := Parent (Par); |
| end loop; |
| |
| if Nkind (Par) = N_Function_Specification then |
| Anon_Scope := Scope (Defining_Entity (Par)); |
| end if; |
| end; |
| |
| -- For the anonymous function result case, retrieve the scope of the |
| -- function specification's associated entity rather than using the |
| -- current scope. The current scope will be the function itself if the |
| -- formal part is currently being analyzed, but will be the parent scope |
| -- in the case of a parameterless function, and we always want to use |
| -- the function's parent scope. Finally, if the function is a child |
| -- unit, we must traverse the tree to retrieve the proper entity. |
| |
| elsif Nkind (Related_Nod) = N_Function_Specification |
| and then Nkind (Parent (N)) /= N_Parameter_Specification |
| then |
| -- If the current scope is a protected type, the anonymous access |
| -- is associated with one of the protected operations, and must |
| -- be available in the scope that encloses the protected declaration. |
| -- Otherwise the type is in the scope enclosing the subprogram. |
| |
| -- If the function has formals, the return type of a subprogram |
| -- declaration is analyzed in the scope of the subprogram (see |
| -- Process_Formals) and thus the protected type, if present, is |
| -- the scope of the current function scope. |
| |
| if Ekind (Current_Scope) = E_Protected_Type then |
| Enclosing_Prot_Type := Current_Scope; |
| |
| elsif Ekind (Current_Scope) = E_Function |
| and then Ekind (Scope (Current_Scope)) = E_Protected_Type |
| then |
| Enclosing_Prot_Type := Scope (Current_Scope); |
| end if; |
| |
| if Present (Enclosing_Prot_Type) then |
| Anon_Scope := Scope (Enclosing_Prot_Type); |
| |
| else |
| Anon_Scope := Scope (Defining_Entity (Related_Nod)); |
| end if; |
| |
| -- For an access type definition, if the current scope is a child |
| -- unit it is the scope of the type. |
| |
| elsif Is_Compilation_Unit (Current_Scope) then |
| Anon_Scope := Current_Scope; |
| |
| -- For access formals, access components, and access discriminants, the |
| -- scope is that of the enclosing declaration, |
| |
| else |
| Anon_Scope := Scope (Current_Scope); |
| end if; |
| |
| Anon_Type := |
| Create_Itype |
| (E_Anonymous_Access_Type, Related_Nod, Scope_Id => Anon_Scope); |
| |
| if All_Present (N) |
| and then Ada_Version >= Ada_2005 |
| then |
| Error_Msg_N ("ALL not permitted for anonymous access types", N); |
| end if; |
| |
| -- Ada 2005 (AI-254): In case of anonymous access to subprograms call |
| -- the corresponding semantic routine |
| |
| if Present (Access_To_Subprogram_Definition (N)) then |
| Access_Subprogram_Declaration |
| (T_Name => Anon_Type, |
| T_Def => Access_To_Subprogram_Definition (N)); |
| |
| if Ekind (Anon_Type) = E_Access_Protected_Subprogram_Type then |
| Mutate_Ekind |
| (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); |
| else |
| Mutate_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); |
| end if; |
| |
| -- If the anonymous access is associated with a protected operation, |
| -- create a reference to it after the enclosing protected definition |
| -- because the itype will be used in the subsequent bodies. |
| |
| -- If the anonymous access itself is protected, a full type |
| -- declaratiton will be created for it, so that the equivalent |
| -- record type can be constructed. For further details, see |
| -- Replace_Anonymous_Access_To_Protected-Subprogram. |
| |
| if Ekind (Current_Scope) = E_Protected_Type |
| and then not Protected_Present (Access_To_Subprogram_Definition (N)) |
| then |
| Build_Itype_Reference (Anon_Type, Parent (Current_Scope)); |
| end if; |
| |
| return Anon_Type; |
| end if; |
| |
| Find_Type (Subtype_Mark (N)); |
| Desig_Type := Entity (Subtype_Mark (N)); |
| |
| Set_Directly_Designated_Type (Anon_Type, Desig_Type); |
| Set_Etype (Anon_Type, Anon_Type); |
| |
| -- Make sure the anonymous access type has size and alignment fields |
| -- set, as required by gigi. This is necessary in the case of the |
| -- Task_Body_Procedure. |
| |
| if not Has_Private_Component (Desig_Type) then |
| Layout_Type (Anon_Type); |
| end if; |
| |
| -- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs |
| -- from Ada 95 semantics. In Ada 2005, anonymous access must specify if |
| -- the null value is allowed. In Ada 95 the null value is never allowed. |
| |
| if Ada_Version >= Ada_2005 then |
| Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N)); |
| else |
| Set_Can_Never_Be_Null (Anon_Type, True); |
| end if; |
| |
| -- The anonymous access type is as public as the discriminated type or |
| -- subprogram that defines it. It is imported (for back-end purposes) |
| -- if the designated type is. |
| |
| Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type))); |
| |
| -- Ada 2005 (AI-231): Propagate the access-constant attribute |
| |
| Set_Is_Access_Constant (Anon_Type, Constant_Present (N)); |
| |
| -- The context is either a subprogram declaration, object declaration, |
| -- or an access discriminant, in a private or a full type declaration. |
| -- In the case of a subprogram, if the designated type is incomplete, |
| -- the operation will be a primitive operation of the full type, to be |
| -- updated subsequently. If the type is imported through a limited_with |
| -- clause, the subprogram is not a primitive operation of the type |
| -- (which is declared elsewhere in some other scope). |
| |
| if Ekind (Desig_Type) = E_Incomplete_Type |
| and then not From_Limited_With (Desig_Type) |
| and then Is_Overloadable (Current_Scope) |
| then |
| Append_Elmt (Current_Scope, Private_Dependents (Desig_Type)); |
| Set_Has_Delayed_Freeze (Current_Scope); |
| end if; |
| |
| -- If the designated type is limited and class-wide, the object might |
| -- contain tasks, so we create a Master entity for the declaration. This |
| -- must be done before expansion of the full declaration, because the |
| -- declaration may include an expression that is an allocator, whose |
| -- expansion needs the proper Master for the created tasks. |
| |
| if Expander_Active |
| and then Nkind (Related_Nod) = N_Object_Declaration |
| then |
| if Is_Limited_Record (Desig_Type) |
| and then Is_Class_Wide_Type (Desig_Type) |
| then |
| Build_Class_Wide_Master (Anon_Type); |
| |
| -- Similarly, if the type is an anonymous access that designates |
| -- tasks, create a master entity for it in the current context. |
| |
| elsif Has_Task (Desig_Type) |
| and then Comes_From_Source (Related_Nod) |
| then |
| Build_Master_Entity (Defining_Identifier (Related_Nod)); |
| Build_Master_Renaming (Anon_Type); |
| end if; |
| end if; |
| |
| -- For a private component of a protected type, it is imperative that |
| -- the back-end elaborate the type immediately after the protected |
| -- declaration, because this type will be used in the declarations |
| -- created for the component within each protected body, so we must |
| -- create an itype reference for it now. |
| |
| if Nkind (Parent (Related_Nod)) = N_Protected_Definition then |
| Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod))); |
| |
| -- Similarly, if the access definition is the return result of a |
| -- function, create an itype reference for it because it will be used |
| -- within the function body. For a regular function that is not a |
| -- compilation unit, insert reference after the declaration. For a |
| -- protected operation, insert it after the enclosing protected type |
| -- declaration. In either case, do not create a reference for a type |
| -- obtained through a limited_with clause, because this would introduce |
| -- semantic dependencies. |
| |
| -- Similarly, do not create a reference if the designated type is a |
| -- generic formal, because no use of it will reach the backend. |
| |
| elsif Nkind (Related_Nod) = N_Function_Specification |
| and then not From_Limited_With (Desig_Type) |
| and then not Is_Generic_Type (Desig_Type) |
| then |
| if Present (Enclosing_Prot_Type) then |
| Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type)); |
| |
| elsif Is_List_Member (Parent (Related_Nod)) |
| and then Nkind (Parent (N)) /= N_Parameter_Specification |
| then |
| Build_Itype_Reference (Anon_Type, Parent (Related_Nod)); |
| end if; |
| |
| -- Finally, create an itype reference for an object declaration of an |
| -- anonymous access type. This is strictly necessary only for deferred |
| -- constants, but in any case will avoid out-of-scope problems in the |
| -- back-end. |
| |
| elsif Nkind (Related_Nod) = N_Object_Declaration then |
| Build_Itype_Reference (Anon_Type, Related_Nod); |
| end if; |
| |
| return Anon_Type; |
| end Access_Definition; |
| |
| ----------------------------------- |
| -- Access_Subprogram_Declaration -- |
| ----------------------------------- |
| |
| procedure Access_Subprogram_Declaration |
| (T_Name : Entity_Id; |
| T_Def : Node_Id) |
| is |
| procedure Check_For_Premature_Usage (Def : Node_Id); |
| -- Check that type T_Name is not used, directly or recursively, as a |
| -- parameter or a return type in Def. Def is either a subtype, an |
| -- access_definition, or an access_to_subprogram_definition. |
| |
| ------------------------------- |
| -- Check_For_Premature_Usage -- |
| ------------------------------- |
| |
| procedure Check_For_Premature_Usage (Def : Node_Id) is |
| Param : Node_Id; |
| |
| begin |
| -- Check for a subtype mark |
| |
| if Nkind (Def) in N_Has_Etype then |
| if Etype (Def) = T_Name then |
| Error_Msg_N |
| ("type& cannot be used before the end of its declaration", |
| Def); |
| end if; |
| |
| -- If this is not a subtype, then this is an access_definition |
| |
| elsif Nkind (Def) = N_Access_Definition then |
| if Present (Access_To_Subprogram_Definition (Def)) then |
| Check_For_Premature_Usage |
| (Access_To_Subprogram_Definition (Def)); |
| else |
| Check_For_Premature_Usage (Subtype_Mark (Def)); |
| end if; |
| |
| -- The only cases left are N_Access_Function_Definition and |
| -- N_Access_Procedure_Definition. |
| |
| else |
| if Present (Parameter_Specifications (Def)) then |
| Param := First (Parameter_Specifications (Def)); |
| while Present (Param) loop |
| Check_For_Premature_Usage (Parameter_Type (Param)); |
| Next (Param); |
| end loop; |
| end if; |
| |
| if Nkind (Def) = N_Access_Function_Definition then |
| Check_For_Premature_Usage (Result_Definition (Def)); |
| end if; |
| end if; |
| end Check_For_Premature_Usage; |
| |
| -- Local variables |
| |
| Formals : constant List_Id := Parameter_Specifications (T_Def); |
| Formal : Entity_Id; |
| D_Ityp : Node_Id; |
| Desig_Type : constant Entity_Id := |
| Create_Itype (E_Subprogram_Type, Parent (T_Def)); |
| |
| -- Start of processing for Access_Subprogram_Declaration |
| |
| begin |
| -- Associate the Itype node with the inner full-type declaration or |
| -- subprogram spec or entry body. This is required to handle nested |
| -- anonymous declarations. For example: |
| |
| -- procedure P |
| -- (X : access procedure |
| -- (Y : access procedure |
| -- (Z : access T))) |
| |
| D_Ityp := Associated_Node_For_Itype (Desig_Type); |
| while Nkind (D_Ityp) not in N_Full_Type_Declaration |
| | N_Private_Type_Declaration |
| | N_Private_Extension_Declaration |
| | N_Procedure_Specification |
| | N_Function_Specification |
| | N_Entry_Body |
| | N_Object_Declaration |
| | N_Object_Renaming_Declaration |
| | N_Formal_Object_Declaration |
| | N_Formal_Type_Declaration |
| | N_Task_Type_Declaration |
| | N_Protected_Type_Declaration |
| loop |
| D_Ityp := Parent (D_Ityp); |
| pragma Assert (D_Ityp /= Empty); |
| end loop; |
| |
| Set_Associated_Node_For_Itype (Desig_Type, D_Ityp); |
| |
| if Nkind (D_Ityp) in N_Procedure_Specification | N_Function_Specification |
| then |
| Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp))); |
| |
| elsif Nkind (D_Ityp) in N_Full_Type_Declaration |
| | N_Object_Declaration |
| | N_Object_Renaming_Declaration |
| | N_Formal_Type_Declaration |
| then |
| Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp))); |
| end if; |
| |
| if Nkind (T_Def) = N_Access_Function_Definition then |
| if Nkind (Result_Definition (T_Def)) = N_Access_Definition then |
| declare |
| Acc : constant Node_Id := Result_Definition (T_Def); |
| |
| begin |
| if Present (Access_To_Subprogram_Definition (Acc)) |
| and then |
| Protected_Present (Access_To_Subprogram_Definition (Acc)) |
| then |
| Set_Etype |
| (Desig_Type, |
| Replace_Anonymous_Access_To_Protected_Subprogram |
| (T_Def)); |
| |
| else |
| Set_Etype |
| (Desig_Type, |
| Access_Definition (T_Def, Result_Definition (T_Def))); |
| end if; |
| end; |
| |
| else |
| Analyze (Result_Definition (T_Def)); |
| |
| declare |
| Typ : constant Entity_Id := Entity (Result_Definition (T_Def)); |
| |
| begin |
| -- If a null exclusion is imposed on the result type, then |
| -- create a null-excluding itype (an access subtype) and use |
| -- it as the function's Etype. |
| |
| if Is_Access_Type (Typ) |
| and then Null_Exclusion_In_Return_Present (T_Def) |
| then |
| Set_Etype (Desig_Type, |
| Create_Null_Excluding_Itype |
| (T => Typ, |
| Related_Nod => T_Def, |
| Scope_Id => Current_Scope)); |
| |
| else |
| if From_Limited_With (Typ) then |
| |
| -- AI05-151: Incomplete types are allowed in all basic |
| -- declarations, including access to subprograms. |
| |
| if Ada_Version >= Ada_2012 then |
| null; |
| |
| else |
| Error_Msg_NE |
| ("illegal use of incomplete type&", |
| Result_Definition (T_Def), Typ); |
| end if; |
| |
| elsif Ekind (Current_Scope) = E_Package |
| and then In_Private_Part (Current_Scope) |
| then |
| if Ekind (Typ) = E_Incomplete_Type then |
| Append_Elmt (Desig_Type, Private_Dependents (Typ)); |
| |
| elsif Is_Class_Wide_Type (Typ) |
| and then Ekind (Etype (Typ)) = E_Incomplete_Type |
| then |
| Append_Elmt |
| (Desig_Type, Private_Dependents (Etype (Typ))); |
| end if; |
| end if; |
| |
| Set_Etype (Desig_Type, Typ); |
| end if; |
| end; |
| end if; |
| |
| if not Is_Type (Etype (Desig_Type)) then |
| Error_Msg_N |
| ("expect type in function specification", |
| Result_Definition (T_Def)); |
| end if; |
| |
| else |
| Set_Etype (Desig_Type, Standard_Void_Type); |
| end if; |
| |
| if Present (Formals) then |
| Push_Scope (Desig_Type); |
| |
| -- Some special tests here. These special tests can be removed |
| -- if and when Itypes always have proper parent pointers to their |
| -- declarations??? |
| |
| -- Special test 1) Link defining_identifier of formals. Required by |
| -- First_Formal to provide its functionality. |
| |
| declare |
| F : Node_Id; |
| |
| begin |
| F := First (Formals); |
| |
| while Present (F) loop |
| if No (Parent (Defining_Identifier (F))) then |
| Set_Parent (Defining_Identifier (F), F); |
| end if; |
| |
| Next (F); |
| end loop; |
| end; |
| |
| Process_Formals (Formals, Parent (T_Def)); |
| |
| -- Special test 2) End_Scope requires that the parent pointer be set |
| -- to something reasonable, but Itypes don't have parent pointers. So |
| -- we set it and then unset it ??? |
| |
| Set_Parent (Desig_Type, T_Name); |
| End_Scope; |
| Set_Parent (Desig_Type, Empty); |
| end if; |
| |
| -- Check for premature usage of the type being defined |
| |
| Check_For_Premature_Usage (T_Def); |
| |
| -- The return type and/or any parameter type may be incomplete. Mark the |
| -- subprogram_type as depending on the incomplete type, so that it can |
| -- be updated when the full type declaration is seen. This only applies |
| -- to incomplete types declared in some enclosing scope, not to limited |
| -- views from other packages. |
| |
| -- Prior to Ada 2012, access to functions can only have in_parameters. |
| |
| if Present (Formals) then |
| Formal := First_Formal (Desig_Type); |
| while Present (Formal) loop |
| if Ekind (Formal) /= E_In_Parameter |
| and then Nkind (T_Def) = N_Access_Function_Definition |
| and then Ada_Version < Ada_2012 |
| then |
| Error_Msg_N ("functions can only have IN parameters", Formal); |
| end if; |
| |
| if Ekind (Etype (Formal)) = E_Incomplete_Type |
| and then In_Open_Scopes (Scope (Etype (Formal))) |
| then |
| Append_Elmt (Desig_Type, Private_Dependents (Etype (Formal))); |
| Set_Has_Delayed_Freeze (Desig_Type); |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| end if; |
| |
| -- Check whether an indirect call without actuals may be possible. This |
| -- is used when resolving calls whose result is then indexed. |
| |
| May_Need_Actuals (Desig_Type); |
| |
| -- If the return type is incomplete, this is legal as long as the type |
| -- is declared in the current scope and will be completed in it (rather |
| -- than being part of limited view). |
| |
| if Ekind (Etype (Desig_Type)) = E_Incomplete_Type |
| and then not Has_Delayed_Freeze (Desig_Type) |
| and then In_Open_Scopes (Scope (Etype (Desig_Type))) |
| then |
| Append_Elmt (Desig_Type, Private_Dependents (Etype (Desig_Type))); |
| Set_Has_Delayed_Freeze (Desig_Type); |
| end if; |
| |
| Check_Delayed_Subprogram (Desig_Type); |
| |
| if Protected_Present (T_Def) then |
| Mutate_Ekind (T_Name, E_Access_Protected_Subprogram_Type); |
| Set_Convention (Desig_Type, Convention_Protected); |
| else |
| Mutate_Ekind (T_Name, E_Access_Subprogram_Type); |
| end if; |
| |
| Set_Can_Use_Internal_Rep (T_Name, |
| not Always_Compatible_Rep_On_Target); |
| Set_Etype (T_Name, T_Name); |
| Reinit_Size_Align (T_Name); |
| Set_Directly_Designated_Type (T_Name, Desig_Type); |
| |
| -- If the access_to_subprogram is not declared at the library level, |
| -- it can only point to subprograms that are at the same or deeper |
| -- accessibility level. The corresponding subprogram type might |
| -- require an activation record when compiling for C. |
| |
| Set_Needs_Activation_Record (Desig_Type, |
| not Is_Library_Level_Entity (T_Name)); |
| |
| Generate_Reference_To_Formals (T_Name); |
| |
| -- Ada 2005 (AI-231): Propagate the null-excluding attribute |
| |
| Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); |
| |
| Check_Restriction (No_Access_Subprograms, T_Def); |
| |
| -- Addition of extra formals must be delayed till the freeze point so |
| -- that we know the convention. |
| end Access_Subprogram_Declaration; |
| |
| ---------------------------- |
| -- Access_Type_Declaration -- |
| ---------------------------- |
| |
| procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is |
| |
| procedure Setup_Access_Type (Desig_Typ : Entity_Id); |
| -- After type declaration is analysed with T being an incomplete type, |
| -- this routine will mutate the kind of T to the appropriate access type |
| -- and set its directly designated type to Desig_Typ. |
| |
| ----------------------- |
| -- Setup_Access_Type -- |
| ----------------------- |
| |
| procedure Setup_Access_Type (Desig_Typ : Entity_Id) is |
| begin |
| if All_Present (Def) or else Constant_Present (Def) then |
| Mutate_Ekind (T, E_General_Access_Type); |
| else |
| Mutate_Ekind (T, E_Access_Type); |
| end if; |
| |
| Set_Directly_Designated_Type (T, Desig_Typ); |
| end Setup_Access_Type; |
| |
| -- Local variables |
| |
| P : constant Node_Id := Parent (Def); |
| S : constant Node_Id := Subtype_Indication (Def); |
| |
| Full_Desig : Entity_Id; |
| |
| -- Start of processing for Access_Type_Declaration |
| |
| begin |
| -- Check for permissible use of incomplete type |
| |
| if Nkind (S) /= N_Subtype_Indication then |
| |
| Analyze (S); |
| |
| if Nkind (S) in N_Has_Entity |
| and then Present (Entity (S)) |
| and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type |
| then |
| Setup_Access_Type (Desig_Typ => Entity (S)); |
| |
| -- If the designated type is a limited view, we cannot tell if |
| -- the full view contains tasks, and there is no way to handle |
| -- that full view in a client. We create a master entity for the |
| -- scope, which will be used when a client determines that one |
| -- is needed. |
| |
| if From_Limited_With (Entity (S)) |
| and then not Is_Class_Wide_Type (Entity (S)) |
| then |
| Build_Master_Entity (T); |
| Build_Master_Renaming (T); |
| end if; |
| |
| else |
| Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); |
| end if; |
| |
| -- If the access definition is of the form: ACCESS NOT NULL .. |
| -- the subtype indication must be of an access type. Create |
| -- a null-excluding subtype of it. |
| |
| if Null_Excluding_Subtype (Def) then |
| if not Is_Access_Type (Entity (S)) then |
| Error_Msg_N ("null exclusion must apply to access type", Def); |
| |
| else |
| declare |
| Loc : constant Source_Ptr := Sloc (S); |
| Decl : Node_Id; |
| Nam : constant Entity_Id := Make_Temporary (Loc, 'S'); |
| |
| begin |
| Decl := |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => Nam, |
| Subtype_Indication => |
| New_Occurrence_Of (Entity (S), Loc)); |
| Set_Null_Exclusion_Present (Decl); |
| Insert_Before (Parent (Def), Decl); |
| Analyze (Decl); |
| Set_Entity (S, Nam); |
| end; |
| end if; |
| end if; |
| |
| else |
| Setup_Access_Type (Desig_Typ => Process_Subtype (S, P, T, 'P')); |
| end if; |
| |
| if not Error_Posted (T) then |
| Full_Desig := Designated_Type (T); |
| |
| if Base_Type (Full_Desig) = T then |
| Error_Msg_N ("access type cannot designate itself", S); |
| |
| -- In Ada 2005, the type may have a limited view through some unit in |
| -- its own context, allowing the following circularity that cannot be |
| -- detected earlier. |
| |
| elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T |
| then |
| Error_Msg_N |
| ("access type cannot designate its own class-wide type", S); |
| |
| -- Clean up indication of tagged status to prevent cascaded errors |
| |
| Set_Is_Tagged_Type (T, False); |
| end if; |
| |
| Set_Etype (T, T); |
| |
| -- For SPARK, check that the designated type is compatible with |
| -- respect to volatility with the access type. |
| |
| if SPARK_Mode /= Off |
| and then Comes_From_Source (T) |
| then |
| -- ??? UNIMPLEMENTED |
| -- In the case where the designated type is incomplete at this |
| -- point, performing this check here is harmless but the check |
| -- will need to be repeated when the designated type is complete. |
| |
| -- The preceding call to Comes_From_Source is needed because the |
| -- FE sometimes introduces implicitly declared access types. See, |
| -- for example, the expansion of nested_po.ads in OA28-015. |
| |
| Check_Volatility_Compatibility |
| (Full_Desig, T, "designated type", "access type", |
| Srcpos_Bearer => T); |
| end if; |
| end if; |
| |
| -- If the type has appeared already in a with_type clause, it is frozen |
| -- and the pointer size is already set. Else, initialize. |
| |
| if not From_Limited_With (T) then |
| Reinit_Size_Align (T); |
| end if; |
| |
| -- Note that Has_Task is always false, since the access type itself |
| -- is not a task type. See Einfo for more description on this point. |
| -- Exactly the same consideration applies to Has_Controlled_Component |
| -- and to Has_Protected. |
| |
| Set_Has_Task (T, False); |
| Set_Has_Protected (T, False); |
| Set_Has_Timing_Event (T, False); |
| Set_Has_Controlled_Component (T, False); |
| |
| -- Initialize field Finalization_Master explicitly to Empty, to avoid |
| -- problems where an incomplete view of this entity has been previously |
| -- established by a limited with and an overlaid version of this field |
| -- (Stored_Constraint) was initialized for the incomplete view. |
| |
| -- This reset is performed in most cases except where the access type |
| -- has been created for the purposes of allocating or deallocating a |
| -- build-in-place object. Such access types have explicitly set pools |
| -- and finalization masters. |
| |
| if No (Associated_Storage_Pool (T)) then |
| Set_Finalization_Master (T, Empty); |
| end if; |
| |
| -- Ada 2005 (AI-231): Propagate the null-excluding and access-constant |
| -- attributes |
| |
| Set_Can_Never_Be_Null (T, Null_Exclusion_Present (Def)); |
| Set_Is_Access_Constant (T, Constant_Present (Def)); |
| end Access_Type_Declaration; |
| |
| ---------------------------------- |
| -- Add_Interface_Tag_Components -- |
| ---------------------------------- |
| |
| procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| L : List_Id; |
| Last_Tag : Node_Id; |
| |
| procedure Add_Tag (Iface : Entity_Id); |
| -- Add tag for one of the progenitor interfaces |
| |
| ------------- |
| -- Add_Tag -- |
| ------------- |
| |
| procedure Add_Tag (Iface : Entity_Id) is |
| Decl : Node_Id; |
| Def : Node_Id; |
| Tag : Entity_Id; |
| Offset : Entity_Id; |
| |
| begin |
| pragma Assert (Is_Tagged_Type (Iface) and then Is_Interface (Iface)); |
| |
| -- This is a reasonable place to propagate predicates |
| |
| if Has_Predicates (Iface) then |
| Set_Has_Predicates (Typ); |
| end if; |
| |
| Def := |
| Make_Component_Definition (Loc, |
| Aliased_Present => True, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); |
| |
| Tag := Make_Temporary (Loc, 'V'); |
| |
| Decl := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Tag, |
| Component_Definition => Def); |
| |
| Analyze_Component_Declaration (Decl); |
| |
| Set_Analyzed (Decl); |
| Mutate_Ekind (Tag, E_Component); |
| Set_Is_Tag (Tag); |
| Set_Is_Aliased (Tag); |
| Set_Is_Independent (Tag); |
| Set_Related_Type (Tag, Iface); |
| Reinit_Component_Location (Tag); |
| |
| pragma Assert (Is_Frozen (Iface)); |
| |
| Set_DT_Entry_Count (Tag, |
| DT_Entry_Count (First_Entity (Iface))); |
| |
| if No (Last_Tag) then |
| Prepend (Decl, L); |
| else |
| Insert_After (Last_Tag, Decl); |
| end if; |
| |
| Last_Tag := Decl; |
| |
| -- If the ancestor has discriminants we need to give special support |
| -- to store the offset_to_top value of the secondary dispatch tables. |
| -- For this purpose we add a supplementary component just after the |
| -- field that contains the tag associated with each secondary DT. |
| |
| if Typ /= Etype (Typ) and then Has_Discriminants (Etype (Typ)) then |
| Def := |
| Make_Component_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); |
| |
| Offset := Make_Temporary (Loc, 'V'); |
| |
| Decl := |
| Make_Component_Declaration (Loc, |
| Defining_Identifier => Offset, |
| Component_Definition => Def); |
| |
| Analyze_Component_Declaration (Decl); |
| |
| Set_Analyzed (Decl); |
| Mutate_Ekind (Offset, E_Component); |
| Set_Is_Aliased (Offset); |
| Set_Is_Independent (Offset); |
| Set_Related_Type (Offset, Iface); |
| Reinit_Component_Location (Offset); |
| Insert_After (Last_Tag, Decl); |
| Last_Tag := Decl; |
| end if; |
| end Add_Tag; |
| |
| -- Local variables |
| |
| Elmt : Elmt_Id; |
| Ext : Node_Id; |
| Comp : Node_Id; |
| |
| -- Start of processing for Add_Interface_Tag_Components |
| |
| begin |
| if not RTE_Available (RE_Interface_Tag) then |
| Error_Msg_N |
| ("(Ada 2005) interface types not supported by this run-time!", N); |
| return; |
| end if; |
| |
| if Ekind (Typ) /= E_Record_Type |
| or else (Is_Concurrent_Record_Type (Typ) |
| and then Is_Empty_List (Abstract_Interface_List (Typ))) |
| or else (not Is_Concurrent_Record_Type (Typ) |
| and then No (Interfaces (Typ)) |
| and then Is_Empty_Elmt_List (Interfaces (Typ))) |
| then |
| return; |
| end if; |
| |
| -- Find the current last tag |
| |
| if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then |
| Ext := Record_Extension_Part (Type_Definition (N)); |
| else |
| pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition); |
| Ext := Type_Definition (N); |
| end if; |
| |
| Last_Tag := Empty; |
| |
| if not (Present (Component_List (Ext))) then |
| Set_Null_Present (Ext, False); |
| L := New_List; |
| Set_Component_List (Ext, |
| Make_Component_List (Loc, |
| Component_Items => L, |
| Null_Present => False)); |
| else |
| if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then |
| L := Component_Items |
| (Component_List |
| (Record_Extension_Part |
| (Type_Definition (N)))); |
| else |
| L := Component_Items |
| (Component_List |
| (Type_Definition (N))); |
| end if; |
| |
| -- Find the last tag component |
| |
| Comp := First (L); |
| while Present (Comp) loop |
| if Nkind (Comp) = N_Component_Declaration |
| and then Is_Tag (Defining_Identifier (Comp)) |
| then |
| Last_Tag := Comp; |
| end if; |
| |
| Next (Comp); |
| end loop; |
| end if; |
| |
| -- At this point L references the list of components and Last_Tag |
| -- references the current last tag (if any). Now we add the tag |
| -- corresponding with all the interfaces that are not implemented |
| -- by the parent. |
| |
| if Present (Interfaces (Typ)) then |
| Elmt := First_Elmt (Interfaces (Typ)); |
| while Present (Elmt) loop |
| Add_Tag (Node (Elmt)); |
| Next_Elmt (Elmt); |
| end loop; |
| end if; |
| end Add_Interface_Tag_Components; |
| |
| ------------------------------------- |
| -- Add_Internal_Interface_Entities -- |
| ------------------------------------- |
| |
| procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is |
| Elmt : Elmt_Id; |
| Iface : Entity_Id; |
| Iface_Elmt : Elmt_Id; |
| Iface_Prim : Entity_Id; |
| Ifaces_List : Elist_Id; |
| New_Subp : Entity_Id := Empty; |
| Prim : Entity_Id; |
| Restore_Scope : Boolean := False; |
| |
| begin |
| pragma Assert (Ada_Version >= Ada_2005 |
| and then Is_Record_Type (Tagged_Type) |
| and then Is_Tagged_Type (Tagged_Type) |
| and then Has_Interfaces (Tagged_Type) |
| and then not Is_Interface (Tagged_Type)); |
| |
| -- Ensure that the internal entities are added to the scope of the type |
| |
| if Scope (Tagged_Type) /= Current_Scope then |
| Push_Scope (Scope (Tagged_Type)); |
| Restore_Scope := True; |
| end if; |
| |
| Collect_Interfaces (Tagged_Type, Ifaces_List); |
| |
| Iface_Elmt := First_Elmt (Ifaces_List); |
| while Present (Iface_Elmt) loop |
| Iface := Node (Iface_Elmt); |
| |
| -- Originally we excluded here from this processing interfaces that |
| -- are parents of Tagged_Type because their primitives are located |
| -- in the primary dispatch table (and hence no auxiliary internal |
| -- entities are required to handle secondary dispatch tables in such |
| -- case). However, these auxiliary entities are also required to |
| -- handle derivations of interfaces in formals of generics (see |
| -- Derive_Subprograms). |
| |
| Elmt := First_Elmt (Primitive_Operations (Iface)); |
| while Present (Elmt) loop |
| Iface_Prim := Node (Elmt); |
| |
| if not Is_Predefined_Dispatching_Operation (Iface_Prim) then |
| Prim := |
| Find_Primitive_Covering_Interface |
| (Tagged_Type => Tagged_Type, |
| Iface_Prim => Iface_Prim); |
| |
| if No (Prim) and then Serious_Errors_Detected > 0 then |
| goto Continue; |
| end if; |
| |
| pragma Assert (Present (Prim)); |
| |
| -- Ada 2012 (AI05-0197): If the name of the covering primitive |
| -- differs from the name of the interface primitive then it is |
| -- a private primitive inherited from a parent type. In such |
| -- case, given that Tagged_Type covers the interface, the |
| -- inherited private primitive becomes visible. For such |
| -- purpose we add a new entity that renames the inherited |
| -- private primitive. |
| |
| if Chars (Prim) /= Chars (Iface_Prim) then |
| pragma Assert (Has_Suffix (Prim, 'P')); |
| Derive_Subprogram |
| (New_Subp => New_Subp, |
| Parent_Subp => Iface_Prim, |
| Derived_Type => Tagged_Type, |
| Parent_Type => Iface); |
| Set_Alias (New_Subp, Prim); |
| Set_Is_Abstract_Subprogram |
| (New_Subp, Is_Abstract_Subprogram (Prim)); |
| end if; |
| |
| Derive_Subprogram |
| (New_Subp => New_Subp, |
| Parent_Subp => Iface_Prim, |
| Derived_Type => Tagged_Type, |
| Parent_Type => Iface); |
| |
| declare |
| Anc : Entity_Id; |
| begin |
| if Is_Inherited_Operation (Prim) |
| and then Present (Alias (Prim)) |
| then |
| Anc := Alias (Prim); |
| else |
| Anc := Overridden_Operation (Prim); |
| end if; |
| |
| -- Apply legality checks in RM 6.1.1 (10-13) concerning |
| -- nonconforming preconditions in both an ancestor and |
| -- a progenitor operation. |
| |
| -- If the operation is a primitive wrapper it is an explicit |
| -- (overriding) operqtion and all is fine. |
| |
| if Present (Anc) |
| and then Has_Non_Trivial_Precondition (Anc) |
| and then Has_Non_Trivial_Precondition (Iface_Prim) |
| then |
| if Is_Abstract_Subprogram (Prim) |
| or else |
| (Ekind (Prim) = E_Procedure |
| and then Nkind (Parent (Prim)) = |
| N_Procedure_Specification |
| and then Null_Present (Parent (Prim))) |
| or else Is_Primitive_Wrapper (Prim) |
| then |
| null; |
| |
| -- The operation is inherited and must be overridden |
| |
| elsif not Comes_From_Source (Prim) then |
| Error_Msg_NE |
| ("&inherits non-conforming preconditions and must " |
| & "be overridden (RM 6.1.1 (10-16))", |
| Parent (Tagged_Type), Prim); |
| end if; |
| end if; |
| end; |
| |
| -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp |
| -- associated with interface types. These entities are |
| -- only registered in the list of primitives of its |
| -- corresponding tagged type because they are only used |
| -- to fill the contents of the secondary dispatch tables. |
| -- Therefore they are removed from the homonym chains. |
| |
| Set_Is_Hidden (New_Subp); |
| Set_Is_Internal (New_Subp); |
| Set_Alias (New_Subp, Prim); |
| Set_Is_Abstract_Subprogram |
| (New_Subp, Is_Abstract_Subprogram (Prim)); |
| Set_Interface_Alias (New_Subp, Iface_Prim); |
| |
| -- If the returned type is an interface then propagate it to |
| -- the returned type. Needed by the thunk to generate the code |
| -- which displaces "this" to reference the corresponding |
| -- secondary dispatch table in the returned object. |
| |
| if Is_Interface (Etype (Iface_Prim)) then |
| Set_Etype (New_Subp, Etype (Iface_Prim)); |
| end if; |
| |
| -- Internal entities associated with interface types are only |
| -- registered in the list of primitives of the tagged type. |
| -- They are only used to fill the contents of the secondary |
| -- dispatch tables. Therefore they are not needed in the |
| -- homonym chains. |
| |
| Remove_Homonym (New_Subp); |
| |
| -- Hidden entities associated with interfaces must have set |
| -- the Has_Delay_Freeze attribute to ensure that, in case |
| -- of locally defined tagged types (or compiling with static |
| -- dispatch tables generation disabled) the corresponding |
| -- entry of the secondary dispatch table is filled when such |
| -- an entity is frozen. |
| |
| Set_Has_Delayed_Freeze (New_Subp); |
| end if; |
| |
| <<Continue>> |
| Next_Elmt (Elmt); |
| end loop; |
| |
| Next_Elmt (Iface_Elmt); |
| end loop; |
| |
| if Restore_Scope then |
| Pop_Scope; |
| end if; |
| end Add_Internal_Interface_Entities; |
| |
| ----------------------------------- |
| -- Analyze_Component_Declaration -- |
| ----------------------------------- |
| |
| procedure Analyze_Component_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (Component_Definition (N)); |
| Id : constant Entity_Id := Defining_Identifier (N); |
| E : constant Node_Id := Expression (N); |
| Typ : constant Node_Id := |
| Subtype_Indication (Component_Definition (N)); |
| T : Entity_Id; |
| P : Entity_Id; |
| |
| function Contains_POC (Constr : Node_Id) return Boolean; |
| -- Determines whether a constraint uses the discriminant of a record |
| -- type thus becoming a per-object constraint (POC). |
| |
| function Is_Known_Limited (Typ : Entity_Id) return Boolean; |
| -- Typ is the type of the current component, check whether this type is |
| -- a limited type. Used to validate declaration against that of |
| -- enclosing record. |
| |
| ------------------ |
| -- Contains_POC -- |
| ------------------ |
| |
| function Contains_POC (Constr : Node_Id) return Boolean is |
| begin |
| -- Prevent cascaded errors |
| |
| if Error_Posted (Constr) then |
| return False; |
| end if; |
| |
| case Nkind (Constr) is |
| when N_Attribute_Reference => |
| return Attribute_Name (Constr) = Name_Access |
| and then Prefix (Constr) = Scope (Entity (Prefix (Constr))); |
| |
| when N_Discriminant_Association => |
| return Denotes_Discriminant (Expression (Constr)); |
| |
| when N_Identifier => |
| return Denotes_Discriminant (Constr); |
| |
| when N_Index_Or_Discriminant_Constraint => |
| declare |
| IDC : Node_Id; |
| |
| begin |
| IDC := First (Constraints (Constr)); |
| while Present (IDC) loop |
| |
| -- One per-object constraint is sufficient |
| |
| if Contains_POC (IDC) then |
| return True; |
| end if; |
| |
| Next (IDC); |
| end loop; |
| |
| return False; |
| end; |
| |
| when N_Range => |
| return Denotes_Discriminant (Low_Bound (Constr)) |
| or else |
| Denotes_Discriminant (High_Bound (Constr)); |
| |
| when N_Range_Constraint => |
| return Denotes_Discriminant (Range_Expression (Constr)); |
| |
| when others => |
| return False; |
| end case; |
| end Contains_POC; |
| |
| ---------------------- |
| -- Is_Known_Limited -- |
| ---------------------- |
| |
| function Is_Known_Limited (Typ : Entity_Id) return Boolean is |
| P : constant Entity_Id := Etype (Typ); |
| R : constant Entity_Id := Root_Type (Typ); |
| |
| begin |
| if Is_Limited_Record (Typ) then |
| return True; |
| |
| -- If the root type is limited (and not a limited interface) so is |
| -- the current type. |
| |
| elsif Is_Limited_Record (R) |
| and then (not Is_Interface (R) or else not Is_Limited_Interface (R)) |
| then |
| return True; |
| |
| -- Else the type may have a limited interface progenitor, but a |
| -- limited record parent that is not an interface. |
| |
| elsif R /= P |
| and then Is_Limited_Record (P) |
| and then not Is_Interface (P) |
| then |
| return True; |
| |
| else |
| return False; |
| end if; |
| end Is_Known_Limited; |
| |
| -- Start of processing for Analyze_Component_Declaration |
| |
| begin |
| Generate_Definition (Id); |
| Enter_Name (Id); |
| |
| if Present (Typ) then |
| T := Find_Type_Of_Object |
| (Subtype_Indication (Component_Definition (N)), N); |
| |
| -- Ada 2005 (AI-230): Access Definition case |
| |
| else |
| pragma Assert (Present |
| (Access_Definition (Component_Definition (N)))); |
| |
| T := Access_Definition |
| (Related_Nod => N, |
| N => Access_Definition (Component_Definition (N))); |
| Set_Is_Local_Anonymous_Access (T); |
| |
| -- Ada 2005 (AI-254) |
| |
| if Present (Access_To_Subprogram_Definition |
| (Access_Definition (Component_Definition (N)))) |
| and then Protected_Present (Access_To_Subprogram_Definition |
| (Access_Definition |
| (Component_Definition (N)))) |
| then |
| T := Replace_Anonymous_Access_To_Protected_Subprogram (N); |
| end if; |
| end if; |
| |
| -- If the subtype is a constrained subtype of the enclosing record, |
| -- (which must have a partial view) the back-end does not properly |
| -- handle the recursion. Rewrite the component declaration with an |
| -- explicit subtype indication, which is acceptable to Gigi. We can copy |
| -- the tree directly because side effects have already been removed from |
| -- discriminant constraints. |
| |
| if Ekind (T) = E_Access_Subtype |
| and then Is_Entity_Name (Subtype_Indication (Component_Definition (N))) |
| and then Comes_From_Source (T) |
| and then Nkind (Parent (T)) = N_Subtype_Declaration |
| and then Etype (Directly_Designated_Type (T)) = Current_Scope |
| then |
| Rewrite |
| (Subtype_Indication (Component_Definition (N)), |
| New_Copy_Tree (Subtype_Indication (Parent (T)))); |
| T := Find_Type_Of_Object |
| (Subtype_Indication (Component_Definition (N)), N); |
| end if; |
| |
| -- If the component declaration includes a default expression, then we |
| -- check that the component is not of a limited type (RM 3.7(5)), |
| -- and do the special preanalysis of the expression (see section on |
| -- "Handling of Default and Per-Object Expressions" in the spec of |
| -- package Sem). |
| |
| if Present (E) then |
| Preanalyze_Default_Expression (E, T); |
| Check_Initialization (T, E); |
| |
| if Ada_Version >= Ada_2005 |
| and then Ekind (T) = E_Anonymous_Access_Type |
| and then Etype (E) /= Any_Type |
| then |
| -- Check RM 3.9.2(9): "if the expected type for an expression is |
| -- an anonymous access-to-specific tagged type, then the object |
| -- designated by the expression shall not be dynamically tagged |
| -- unless it is a controlling operand in a call on a dispatching |
| -- operation" |
| |
| if Is_Tagged_Type (Directly_Designated_Type (T)) |
| and then |
| Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type |
| and then |
| Ekind (Directly_Designated_Type (Etype (E))) = |
| E_Class_Wide_Type |
| then |
| Error_Msg_N |
| ("access to specific tagged type required (RM 3.9.2(9))", E); |
| end if; |
| |
| -- (Ada 2005: AI-230): Accessibility check for anonymous |
| -- components |
| |
| if Type_Access_Level (Etype (E)) > |
| Deepest_Type_Access_Level (T) |
| then |
| Error_Msg_N |
| ("expression has deeper access level than component " & |
| "(RM 3.10.2 (12.2))", E); |
| end if; |
| |
| -- The initialization expression is a reference to an access |
| -- discriminant. The type of the discriminant is always deeper |
| -- than any access type. |
| |
| if Ekind (Etype (E)) = E_Anonymous_Access_Type |
| and then Is_Entity_Name (E) |
| and then Ekind (Entity (E)) = E_In_Parameter |
| and then Present (Discriminal_Link (Entity (E))) |
| then |
| Error_Msg_N |
| ("discriminant has deeper accessibility level than target", |
| E); |
| end if; |
| end if; |
| end if; |
| |
| -- The parent type may be a private view with unknown discriminants, |
| -- and thus unconstrained. Regular components must be constrained. |
| |
| if not Is_Definite_Subtype (T) |
| and then Chars (Id) /= Name_uParent |
| then |
| if Is_Class_Wide_Type (T) then |
| Error_Msg_N |
| ("class-wide subtype with unknown discriminants" & |
| " in component declaration", |
| Subtype_Indication (Component_Definition (N))); |
| else |
| Error_Msg_N |
| ("unconstrained subtype in component declaration", |
| Subtype_Indication (Component_Definition (N))); |
| end if; |
| |
| -- Components cannot be abstract, except for the special case of |
| -- the _Parent field (case of extending an abstract tagged type) |
| |
| elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then |
| Error_Msg_N ("type of a component cannot be abstract", N); |
| end if; |
| |
| Set_Etype (Id, T); |
| |
| if Aliased_Present (Component_Definition (N)) then |
| Set_Is_Aliased (Id); |
| |
| -- AI12-001: All aliased objects are considered to be specified as |
| -- independently addressable (RM C.6(8.1/4)). |
| |
| Set_Is_Independent (Id); |
| end if; |
| |
| -- The component declaration may have a per-object constraint, set |
| -- the appropriate flag in the defining identifier of the subtype. |
| |
| if Present (Subtype_Indication (Component_Definition (N))) then |
| declare |
| Sindic : constant Node_Id := |
| Subtype_Indication (Component_Definition (N)); |
| begin |
| if Nkind (Sindic) = N_Subtype_Indication |
| and then Present (Constraint (Sindic)) |
| and then Contains_POC (Constraint (Sindic)) |
| then |
| Set_Has_Per_Object_Constraint (Id); |
| end if; |
| end; |
| end if; |
| |
| -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry |
| -- out some static checks. |
| |
| if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then |
| Null_Exclusion_Static_Checks (N); |
| end if; |
| |
| -- If this component is private (or depends on a private type), flag the |
| -- record type to indicate that some operations are not available. |
| |
| P := Private_Component (T); |
| |
| if Present (P) then |
| |
| -- Check for circular definitions |
| |
| if P = Any_Type then |
| Set_Etype (Id, Any_Type); |
| |
| -- There is a gap in the visibility of operations only if the |
| -- component type is not defined in the scope of the record type. |
| |
| elsif Scope (P) = Scope (Current_Scope) then |
| null; |
| |
| elsif Is_Limited_Type (P) then |
| Set_Is_Limited_Composite (Current_Scope); |
| |
| else |
| Set_Is_Private_Composite (Current_Scope); |
| end if; |
| end if; |
| |
| if P /= Any_Type |
| and then Is_Limited_Type (T) |
| and then Chars (Id) /= Name_uParent |
| and then Is_Tagged_Type (Current_Scope) |
| then |
| if Is_Derived_Type (Current_Scope) |
| and then not Is_Known_Limited (Current_Scope) |
| then |
| Error_Msg_N |
| ("extension of nonlimited type cannot have limited components", |
| N); |
| |
| if Is_Interface (Root_Type (Current_Scope)) then |
| Error_Msg_N |
| ("\limitedness is not inherited from limited interface", N); |
| Error_Msg_N ("\add LIMITED to type indication", N); |
| end if; |
| |
| Explain_Limited_Type (T, N); |
| Set_Etype (Id, Any_Type); |
| Set_Is_Limited_Composite (Current_Scope, False); |
| |
| elsif not Is_Derived_Type (Current_Scope) |
| and then not Is_Limited_Record (Current_Scope) |
| and then not Is_Concurrent_Type (Current_Scope) |
| then |
| Error_Msg_N |
| ("nonlimited tagged type cannot have limited components", N); |
| Explain_Limited_Type (T, N); |
| Set_Etype (Id, Any_Type); |
| Set_Is_Limited_Composite (Current_Scope, False); |
| end if; |
| end if; |
| |
| -- When possible, build the default subtype |
| |
| if Build_Default_Subtype_OK (T) then |
| declare |
| Act_T : constant Entity_Id := Build_Default_Subtype (T, N); |
| |
| begin |
| Set_Etype (Id, Act_T); |
| |
| -- Rewrite component definition to use the constrained subtype |
| |
| Rewrite (Component_Definition (N), |
| Make_Component_Definition (Loc, |
| Subtype_Indication => New_Occurrence_Of (Act_T, Loc))); |
| end; |
| end if; |
| |
| Set_Original_Record_Component (Id, Id); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Id); |
| end if; |
| |
| Analyze_Dimension (N); |
| end Analyze_Component_Declaration; |
| |
| -------------------------- |
| -- Analyze_Declarations -- |
| -------------------------- |
| |
| procedure Analyze_Declarations (L : List_Id) is |
| Decl : Node_Id; |
| |
| procedure Adjust_Decl; |
| -- Adjust Decl not to include implicit label declarations, since these |
| -- have strange Sloc values that result in elaboration check problems. |
| -- (They have the sloc of the label as found in the source, and that |
| -- is ahead of the current declarative part). |
| |
| procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id); |
| -- Create the subprogram bodies which verify the run-time semantics of |
| -- the pragmas listed below for each elibigle type found in declarative |
| -- list Decls. The pragmas are: |
| -- |
| -- Default_Initial_Condition |
| -- Invariant |
| -- Type_Invariant |
| -- |
| -- Context denotes the owner of the declarative list. |
| |
| procedure Check_Entry_Contracts; |
| -- Perform a preanalysis of the pre- and postconditions of an entry |
| -- declaration. This must be done before full resolution and creation |
| -- of the parameter block, etc. to catch illegal uses within the |
| -- contract expression. Full analysis of the expression is done when |
| -- the contract is processed. |
| |
| function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean; |
| -- Check if a nested package has entities within it that rely on library |
| -- level private types where the full view has not been completed for |
| -- the purposes of checking if it is acceptable to freeze an expression |
| -- function at the point of declaration. |
| |
| procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); |
| -- Determine whether Body_Decl denotes the body of a late controlled |
| -- primitive (either Initialize, Adjust or Finalize). If this is the |
| -- case, add a proper spec if the body lacks one. The spec is inserted |
| -- before Body_Decl and immediately analyzed. |
| |
| procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id); |
| -- Spec_Id is the entity of a package that may define abstract states, |
| -- and in the case of a child unit, whose ancestors may define abstract |
| -- states. If the states have partial visible refinement, remove the |
| -- partial visibility of each constituent at the end of the package |
| -- spec and body declarations. |
| |
| procedure Remove_Visible_Refinements (Spec_Id : Entity_Id); |
| -- Spec_Id is the entity of a package that may define abstract states. |
| -- If the states have visible refinement, remove the visibility of each |
| -- constituent at the end of the package body declaration. |
| |
| procedure Resolve_Aspects; |
| -- Utility to resolve the expressions of aspects at the end of a list of |
| -- declarations, or before a declaration that freezes previous entities, |
| -- such as in a subprogram body. |
| |
| ----------------- |
| -- Adjust_Decl -- |
| ----------------- |
| |
| procedure Adjust_Decl is |
| begin |
| while Present (Prev (Decl)) |
| and then Nkind (Decl) = N_Implicit_Label_Declaration |
| loop |
| Prev (Decl); |
| end loop; |
| end Adjust_Decl; |
| |
| ---------------------------- |
| -- Build_Assertion_Bodies -- |
| ---------------------------- |
| |
| procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is |
| procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id); |
| -- Create the subprogram bodies which verify the run-time semantics |
| -- of the pragmas listed below for type Typ. The pragmas are: |
| -- |
| -- Default_Initial_Condition |
| -- Invariant |
| -- Type_Invariant |
| |
| ------------------------------------- |
| -- Build_Assertion_Bodies_For_Type -- |
| ------------------------------------- |
| |
| procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is |
| begin |
| if Nkind (Context) = N_Package_Specification then |
| |
| -- Preanalyze and resolve the class-wide invariants of an |
| -- interface at the end of whichever declarative part has the |
| -- interface type. Note that an interface may be declared in |
| -- any non-package declarative part, but reaching the end of |
| -- such a declarative part will always freeze the type and |
| -- generate the invariant procedure (see Freeze_Type). |
| |
| if Is_Interface (Typ) then |
| |
| -- Interfaces are treated as the partial view of a private |
| -- type, in order to achieve uniformity with the general |
| -- case. As a result, an interface receives only a "partial" |
| -- invariant procedure, which is never called. |
| |
| if Has_Own_Invariants (Typ) then |
| Build_Invariant_Procedure_Body |
| (Typ => Typ, |
| Partial_Invariant => True); |
| end if; |
| |
| elsif Decls = Visible_Declarations (Context) then |
| -- Preanalyze and resolve the invariants of a private type |
| -- at the end of the visible declarations to catch potential |
| -- errors. Inherited class-wide invariants are not included |
| -- because they have already been resolved. |
| |
| if Ekind (Typ) in E_Limited_Private_Type |
| | E_Private_Type |
| | E_Record_Type_With_Private |
| and then Has_Own_Invariants (Typ) |
| then |
| Build_Invariant_Procedure_Body |
| (Typ => Typ, |
| Partial_Invariant => True); |
| end if; |
| |
| -- Preanalyze and resolve the Default_Initial_Condition |
| -- assertion expression at the end of the declarations to |
| -- catch any errors. |
| |
| if Ekind (Typ) in E_Limited_Private_Type |
| | E_Private_Type |
| | E_Record_Type_With_Private |
| and then Has_Own_DIC (Typ) |
| then |
| Build_DIC_Procedure_Body |
| (Typ => Typ, |
| Partial_DIC => True); |
| end if; |
| |
| elsif Decls = Private_Declarations (Context) then |
| |
| -- Preanalyze and resolve the invariants of a private type's |
| -- full view at the end of the private declarations to catch |
| -- potential errors. |
| |
| if (not Is_Private_Type (Typ) |
| or else Present (Underlying_Full_View (Typ))) |
| and then Has_Private_Declaration (Typ) |
| and then Has_Invariants (Typ) |
| then |
| Build_Invariant_Procedure_Body (Typ); |
| end if; |
| |
| if (not Is_Private_Type (Typ) |
| or else Present (Underlying_Full_View (Typ))) |
| and then Has_Private_Declaration (Typ) |
| and then Has_DIC (Typ) |
| then |
| Build_DIC_Procedure_Body (Typ); |
| end if; |
| end if; |
| end if; |
| end Build_Assertion_Bodies_For_Type; |
| |
| -- Local variables |
| |
| Decl : Node_Id; |
| Decl_Id : Entity_Id; |
| |
| -- Start of processing for Build_Assertion_Bodies |
| |
| begin |
| Decl := First (Decls); |
| while Present (Decl) loop |
| if Is_Declaration (Decl) then |
| Decl_Id := Defining_Entity (Decl); |
| |
| if Is_Type (Decl_Id) then |
| Build_Assertion_Bodies_For_Type (Decl_Id); |
| end if; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end Build_Assertion_Bodies; |
| |
| --------------------------- |
| -- Check_Entry_Contracts -- |
| --------------------------- |
| |
| procedure Check_Entry_Contracts is |
| ASN : Node_Id; |
| Ent : Entity_Id; |
| Exp : Node_Id; |
| |
| begin |
| Ent := First_Entity (Current_Scope); |
| while Present (Ent) loop |
| |
| -- This only concerns entries with pre/postconditions |
| |
| if Ekind (Ent) = E_Entry |
| and then Present (Contract (Ent)) |
| and then Present (Pre_Post_Conditions (Contract (Ent))) |
| then |
| ASN := Pre_Post_Conditions (Contract (Ent)); |
| Push_Scope (Ent); |
| Install_Formals (Ent); |
| |
| -- Pre/postconditions are rewritten as Check pragmas. Analysis |
| -- is performed on a copy of the pragma expression, to prevent |
| -- modifying the original expression. |
| |
| while Present (ASN) loop |
| if Nkind (ASN) = N_Pragma then |
| Exp := |
| New_Copy_Tree |
| (Expression |
| (First (Pragma_Argument_Associations (ASN)))); |
| Set_Parent (Exp, ASN); |
| |
| Preanalyze_Assert_Expression (Exp, Standard_Boolean); |
| end if; |
| |
| ASN := Next_Pragma (ASN); |
| end loop; |
| |
| End_Scope; |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| end Check_Entry_Contracts; |
| |
| ---------------------------------- |
| -- Contains_Lib_Incomplete_Type -- |
| ---------------------------------- |
| |
| function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is |
| Curr : Entity_Id; |
| |
| begin |
| -- Avoid looking through scopes that do not meet the precondition of |
| -- Pkg not being within a library unit spec. |
| |
| if not Is_Compilation_Unit (Pkg) |
| and then not Is_Generic_Instance (Pkg) |
| and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg)) |
| then |
| -- Loop through all entities in the current scope to identify |
| -- an entity that depends on a private type. |
| |
| Curr := First_Entity (Pkg); |
| loop |
| if Nkind (Curr) in N_Entity |
| and then Depends_On_Private (Curr) |
| then |
| return True; |
| end if; |
| |
| exit when Last_Entity (Current_Scope) = Curr; |
| Next_Entity (Curr); |
| end loop; |
| end if; |
| |
| return False; |
| end Contains_Lib_Incomplete_Type; |
| |
| -------------------------------------- |
| -- Handle_Late_Controlled_Primitive -- |
| -------------------------------------- |
| |
| procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id) is |
| Body_Spec : constant Node_Id := Specification (Body_Decl); |
| Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); |
| Loc : constant Source_Ptr := Sloc (Body_Id); |
| Params : constant List_Id := |
| Parameter_Specifications (Body_Spec); |
| Spec : Node_Id; |
| Spec_Id : Entity_Id; |
| Typ : Node_Id; |
| |
| begin |
| -- Consider only procedure bodies whose name matches one of the three |
| -- controlled primitives. |
| |
| if Nkind (Body_Spec) /= N_Procedure_Specification |
| or else Chars (Body_Id) not in Name_Adjust |
| | Name_Finalize |
| | Name_Initialize |
| then |
| return; |
| |
| -- A controlled primitive must have exactly one formal which is not |
| -- an anonymous access type. |
| |
| elsif List_Length (Params) /= 1 then |
| return; |
| end if; |
| |
| Typ := Parameter_Type (First (Params)); |
| |
| if Nkind (Typ) = N_Access_Definition then |
| return; |
| end if; |
| |
| Find_Type (Typ); |
| |
| -- The type of the formal must be derived from [Limited_]Controlled |
| |
| if not Is_Controlled (Entity (Typ)) then |
| return; |
| end if; |
| |
| -- Check whether a specification exists for this body. We do not |
| -- analyze the spec of the body in full, because it will be analyzed |
| -- again when the body is properly analyzed, and we cannot create |
| -- duplicate entries in the formals chain. We look for an explicit |
| -- specification because the body may be an overriding operation and |
| -- an inherited spec may be present. |
| |
| Spec_Id := Current_Entity (Body_Id); |
| |
| while Present (Spec_Id) loop |
| if Ekind (Spec_Id) in E_Procedure | E_Generic_Procedure |
| and then Scope (Spec_Id) = Current_Scope |
| and then Present (First_Formal (Spec_Id)) |
| and then No (Next_Formal (First_Formal (Spec_Id))) |
| and then Etype (First_Formal (Spec_Id)) = Entity (Typ) |
| and then Comes_From_Source (Spec_Id) |
| then |
| return; |
| end if; |
| |
| Spec_Id := Homonym (Spec_Id); |
| end loop; |
| |
| -- At this point the body is known to be a late controlled primitive. |
| -- Generate a matching spec and insert it before the body. Note the |
| -- use of Copy_Separate_Tree - we want an entirely separate semantic |
| -- tree in this case. |
| |
| Spec := Copy_Separate_Tree (Body_Spec); |
| |
| -- Ensure that the subprogram declaration does not inherit the null |
| -- indicator from the body as we now have a proper spec/body pair. |
| |
| Set_Null_Present (Spec, False); |
| |
| -- Ensure that the freeze node is inserted after the declaration of |
| -- the primitive since its expansion will freeze the primitive. |
| |
| Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); |
| |
| Insert_Before_And_Analyze (Body_Decl, Decl); |
| end Handle_Late_Controlled_Primitive; |
| |
| ---------------------------------------- |
| -- Remove_Partial_Visible_Refinements -- |
| ---------------------------------------- |
| |
| procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is |
| State_Elmt : Elmt_Id; |
| begin |
| if Present (Abstract_States (Spec_Id)) then |
| State_Elmt := First_Elmt (Abstract_States (Spec_Id)); |
| while Present (State_Elmt) loop |
| Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False); |
| Next_Elmt (State_Elmt); |
| end loop; |
| end if; |
| |
| -- For a child unit, also hide the partial state refinement from |
| -- ancestor packages. |
| |
| if Is_Child_Unit (Spec_Id) then |
| Remove_Partial_Visible_Refinements (Scope (Spec_Id)); |
| end if; |
| end Remove_Partial_Visible_Refinements; |
| |
| -------------------------------- |
| -- Remove_Visible_Refinements -- |
| -------------------------------- |
| |
| procedure Remove_Visible_Refinements (Spec_Id : Entity_Id) is |
| State_Elmt : Elmt_Id; |
| begin |
| if Present (Abstract_States (Spec_Id)) then |
| State_Elmt := First_Elmt (Abstract_States (Spec_Id)); |
| while Present (State_Elmt) loop |
| Set_Has_Visible_Refinement (Node (State_Elmt), False); |
| Next_Elmt (State_Elmt); |
| end loop; |
| end if; |
| end Remove_Visible_Refinements; |
| |
| --------------------- |
| -- Resolve_Aspects -- |
| --------------------- |
| |
| procedure Resolve_Aspects is |
| E : Entity_Id; |
| |
| begin |
| E := First_Entity (Current_Scope); |
| while Present (E) loop |
| Resolve_Aspect_Expressions (E); |
| |
| -- Now that the aspect expressions have been resolved, if this is |
| -- at the end of the visible declarations, we can set the flag |
| -- Known_To_Have_Preelab_Init properly on types declared in the |
| -- visible part, which is needed for checking whether full types |
| -- in the private part satisfy the Preelaborable_Initialization |
| -- aspect of the partial view. We can't wait for the creation of |
| -- the pragma by Analyze_Aspects_At_Freeze_Point, because the |
| -- freeze point may occur after the end of the package declaration |
| -- (in the case of nested packages). |
| |
| if Is_Type (E) |
| and then L = Visible_Declarations (Parent (L)) |
| and then Has_Aspect (E, Aspect_Preelaborable_Initialization) |
| then |
| declare |
| ASN : constant Node_Id := |
| Find_Aspect (E, Aspect_Preelaborable_Initialization); |
| Expr : constant Node_Id := Expression (ASN); |
| begin |
| -- Set Known_To_Have_Preelab_Init to True if aspect has no |
| -- expression, or if the expression is True (or was folded |
| -- to True), or if the expression is a conjunction of one or |
| -- more Preelaborable_Initialization attributes applied to |
| -- formal types and wasn't folded to False. (Note that |
| -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to |
| -- Original_Node if needed, hence test for Standard_False.) |
| |
| if No (Expr) |
| or else (Is_Entity_Name (Expr) |
| and then Entity (Expr) = Standard_True) |
| or else |
| (Is_Conjunction_Of_Formal_Preelab_Init_Attributes (Expr) |
| and then |
| not (Is_Entity_Name (Expr) |
| and then Entity (Expr) = Standard_False)) |
| then |
| Set_Known_To_Have_Preelab_Init (E); |
| end if; |
| end; |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| end Resolve_Aspects; |
| |
| -- Local variables |
| |
| Context : Node_Id := Empty; |
| Ctrl_Typ : Entity_Id := Empty; |
| Freeze_From : Entity_Id := Empty; |
| Next_Decl : Node_Id; |
| |
| -- Start of processing for Analyze_Declarations |
| |
| begin |
| Decl := First (L); |
| while Present (Decl) loop |
| |
| -- Complete analysis of declaration |
| |
| Analyze (Decl); |
| Next_Decl := Next (Decl); |
| |
| if No (Freeze_From) then |
| Freeze_From := First_Entity (Current_Scope); |
| end if; |
| |
| -- Remember if the declaration we just processed is the full type |
| -- declaration of a controlled type (to handle late overriding of |
| -- initialize, adjust or finalize). |
| |
| if Nkind (Decl) = N_Full_Type_Declaration |
| and then Is_Controlled (Defining_Identifier (Decl)) |
| then |
| Ctrl_Typ := Defining_Identifier (Decl); |
| end if; |
| |
| -- At the end of a declarative part, freeze remaining entities |
| -- declared in it. The end of the visible declarations of package |
| -- specification is not the end of a declarative part if private |
| -- declarations are present. The end of a package declaration is a |
| -- freezing point only if it a library package. A task definition or |
| -- protected type definition is not a freeze point either. Finally, |
| -- we do not freeze entities in generic scopes, because there is no |
| -- code generated for them and freeze nodes will be generated for |
| -- the instance. |
| |
| -- The end of a package instantiation is not a freeze point, but |
| -- for now we make it one, because the generic body is inserted |
| -- (currently) immediately after. Generic instantiations will not |
| -- be a freeze point once delayed freezing of bodies is implemented. |
| -- (This is needed in any case for early instantiations ???). |
| |
| if No (Next_Decl) then |
| if Nkind (Parent (L)) = N_Component_List then |
| null; |
| |
| elsif Nkind (Parent (L)) in |
| N_Protected_Definition | N_Task_Definition |
| then |
| Check_Entry_Contracts; |
| |
| elsif Nkind (Parent (L)) /= N_Package_Specification then |
| if Nkind (Parent (L)) = N_Package_Body then |
| Freeze_From := First_Entity (Current_Scope); |
| end if; |
| |
| -- There may have been several freezing points previously, |
| -- for example object declarations or subprogram bodies, but |
| -- at the end of a declarative part we check freezing from |
| -- the beginning, even though entities may already be frozen, |
| -- in order to perform visibility checks on delayed aspects. |
| |
| Adjust_Decl; |
| |
| -- If the current scope is a generic subprogram body. Skip the |
| -- generic formal parameters that are not frozen here. |
| |
| if Is_Subprogram (Current_Scope) |
| and then Nkind (Unit_Declaration_Node (Current_Scope)) = |
| N_Generic_Subprogram_Declaration |
| and then Present (First_Entity (Current_Scope)) |
| then |
| while Is_Generic_Formal (Freeze_From) loop |
| Next_Entity (Freeze_From); |
| end loop; |
| |
| Freeze_All (Freeze_From, Decl); |
| Freeze_From := Last_Entity (Current_Scope); |
| |
| else |
| -- For declarations in a subprogram body there is no issue |
| -- with name resolution in aspect specifications. |
| |
| Freeze_All (First_Entity (Current_Scope), Decl); |
| Freeze_From := Last_Entity (Current_Scope); |
| end if; |
| |
| -- Current scope is a package specification |
| |
| elsif Scope (Current_Scope) /= Standard_Standard |
| and then not Is_Child_Unit (Current_Scope) |
| and then No (Generic_Parent (Parent (L))) |
| then |
| -- ARM rule 13.1.1(11/3): usage names in aspect definitions are |
| -- resolved at the end of the immediately enclosing declaration |
| -- list (AI05-0183-1). |
| |
| Resolve_Aspects; |
| |
| elsif L /= Visible_Declarations (Parent (L)) |
| or else Is_Empty_List (Private_Declarations (Parent (L))) |
| then |
| Adjust_Decl; |
| |
| -- End of a package declaration |
| |
| -- This is a freeze point because it is the end of a |
| -- compilation unit. |
| |
| Freeze_All (First_Entity (Current_Scope), Decl); |
| Freeze_From := Last_Entity (Current_Scope); |
| |
| -- At the end of the visible declarations the expressions in |
| -- aspects of all entities declared so far must be resolved. |
| -- The entities themselves might be frozen later, and the |
| -- generated pragmas and attribute definition clauses analyzed |
| -- in full at that point, but name resolution must take place |
| -- now. |
| -- In addition to being the proper semantics, this is mandatory |
| -- within generic units, because global name capture requires |
| -- those expressions to be analyzed, given that the generated |
| -- pragmas do not appear in the original generic tree. |
| |
| elsif Serious_Errors_Detected = 0 then |
| Resolve_Aspects; |
| end if; |
| |
| -- If next node is a body then freeze all types before the body. |
| -- An exception occurs for some expander-generated bodies. If these |
| -- are generated at places where in general language rules would not |
| -- allow a freeze point, then we assume that the expander has |
| -- explicitly checked that all required types are properly frozen, |
| -- and we do not cause general freezing here. This special circuit |
| -- is used when the encountered body is marked as having already |
| -- been analyzed. |
| |
| -- In all other cases (bodies that come from source, and expander |
| -- generated bodies that have not been analyzed yet), freeze all |
| -- types now. Note that in the latter case, the expander must take |
| -- care to attach the bodies at a proper place in the tree so as to |
| -- not cause unwanted freezing at that point. |
| |
| -- It is also necessary to check for a case where both an expression |
| -- function is used and the current scope depends on an incomplete |
| -- private type from a library unit, otherwise premature freezing of |
| -- the private type will occur. |
| |
| elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) |
| and then ((Nkind (Next_Decl) /= N_Subprogram_Body |
| or else not Was_Expression_Function (Next_Decl)) |
| or else (not Is_Ignored_Ghost_Entity (Current_Scope) |
| and then not Contains_Lib_Incomplete_Type |
| (Current_Scope))) |
| then |
| -- When a controlled type is frozen, the expander generates stream |
| -- and controlled-type support routines. If the freeze is caused |
| -- by the stand-alone body of Initialize, Adjust, or Finalize, the |
| -- expander will end up using the wrong version of these routines, |
| -- as the body has not been processed yet. To remedy this, detect |
| -- a late controlled primitive and create a proper spec for it. |
| -- This ensures that the primitive will override its inherited |
| -- counterpart before the freeze takes place. |
| |
| -- If the declaration we just processed is a body, do not attempt |
| -- to examine Next_Decl as the late primitive idiom can only apply |
| -- to the first encountered body. |
| |
| -- ??? A cleaner approach may be possible and/or this solution |
| -- could be extended to general-purpose late primitives. |
| |
| if Present (Ctrl_Typ) then |
| |
| -- No need to continue searching for late body overriding if |
| -- the controlled type is already frozen. |
| |
| if Is_Frozen (Ctrl_Typ) then |
| Ctrl_Typ := Empty; |
| |
| elsif Nkind (Next_Decl) = N_Subprogram_Body then |
| Handle_Late_Controlled_Primitive (Next_Decl); |
| end if; |
| end if; |
| |
| Adjust_Decl; |
| |
| -- The generated body of an expression function does not freeze, |
| -- unless it is a completion, in which case only the expression |
| -- itself freezes. This is handled when the body itself is |
| -- analyzed (see Freeze_Expr_Types, sem_ch6.adb). |
| |
| Freeze_All (Freeze_From, Decl); |
| Freeze_From := Last_Entity (Current_Scope); |
| end if; |
| |
| Decl := Next_Decl; |
| end loop; |
| |
| -- Post-freezing actions |
| |
| if Present (L) then |
| Context := Parent (L); |
| |
| -- Certain contract annotations have forward visibility semantics and |
| -- must be analyzed after all declarative items have been processed. |
| -- This timing ensures that entities referenced by such contracts are |
| -- visible. |
| |
| -- Analyze the contract of an immediately enclosing package spec or |
| -- body first because other contracts may depend on its information. |
| |
| if Nkind (Context) = N_Package_Body then |
| Analyze_Package_Body_Contract (Defining_Entity (Context)); |
| |
| elsif Nkind (Context) = N_Package_Specification then |
| Analyze_Package_Contract (Defining_Entity (Context)); |
| end if; |
| |
| -- Analyze the contracts of various constructs in the declarative |
| -- list. |
| |
| Analyze_Contracts (L); |
| |
| if Nkind (Context) = N_Package_Body then |
| |
| -- Ensure that all abstract states and objects declared in the |
| -- state space of a package body are utilized as constituents. |
| |
| Check_Unused_Body_States (Defining_Entity (Context)); |
| |
| -- State refinements are visible up to the end of the package body |
| -- declarations. Hide the state refinements from visibility to |
| -- restore the original state conditions. |
| |
| Remove_Visible_Refinements (Corresponding_Spec (Context)); |
| Remove_Partial_Visible_Refinements (Corresponding_Spec (Context)); |
| |
| elsif Nkind (Context) = N_Package_Specification then |
| |
| -- Partial state refinements are visible up to the end of the |
| -- package spec declarations. Hide the partial state refinements |
| -- from visibility to restore the original state conditions. |
| |
| Remove_Partial_Visible_Refinements (Defining_Entity (Context)); |
| end if; |
| |
| -- Verify that all abstract states found in any package declared in |
| -- the input declarative list have proper refinements. The check is |
| -- performed only when the context denotes a block, entry, package, |
| -- protected, subprogram, or task body (SPARK RM 7.2.2(3)). |
| |
| Check_State_Refinements (Context); |
| |
| -- Create the subprogram bodies which verify the run-time semantics |
| -- of pragmas Default_Initial_Condition and [Type_]Invariant for all |
| -- types within the current declarative list. This ensures that all |
| -- assertion expressions are preanalyzed and resolved at the end of |
| -- the declarative part. Note that the resolution happens even when |
| -- freezing does not take place. |
| |
| Build_Assertion_Bodies (L, Context); |
| end if; |
| end Analyze_Declarations; |
| |
| ----------------------------------- |
| -- Analyze_Full_Type_Declaration -- |
| ----------------------------------- |
| |
| procedure Analyze_Full_Type_Declaration (N : Node_Id) is |
| Def : constant Node_Id := Type_Definition (N); |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| T : Entity_Id; |
| Prev : Entity_Id; |
| |
| Is_Remote : constant Boolean := |
| (Is_Remote_Types (Current_Scope) |
| or else Is_Remote_Call_Interface (Current_Scope)) |
| and then not (In_Private_Part (Current_Scope) |
| or else In_Package_Body (Current_Scope)); |
| |
| procedure Check_Nonoverridable_Aspects; |
| -- Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot |
| -- be overridden, and can only be confirmed on derivation. |
| |
| procedure Check_Ops_From_Incomplete_Type; |
| -- If there is a tagged incomplete partial view of the type, traverse |
| -- the primitives of the incomplete view and change the type of any |
| -- controlling formals and result to indicate the full view. The |
| -- primitives will be added to the full type's primitive operations |
| -- list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which |
| -- is called from Process_Incomplete_Dependents). |
| |
| ---------------------------------- |
| -- Check_Nonoverridable_Aspects -- |
| ---------------------------------- |
| |
| procedure Check_Nonoverridable_Aspects is |
| function Get_Aspect_Spec |
| (Specs : List_Id; |
| Aspect_Name : Name_Id) return Node_Id; |
| -- Check whether a list of aspect specifications includes an entry |
| -- for a specific aspect. The list is either that of a partial or |
| -- a full view. |
| |
| --------------------- |
| -- Get_Aspect_Spec -- |
| --------------------- |
| |
| function Get_Aspect_Spec |
| (Specs : List_Id; |
| Aspect_Name : Name_Id) return Node_Id |
| is |
| Spec : Node_Id; |
| |
| begin |
| Spec := First (Specs); |
| while Present (Spec) loop |
| if Chars (Identifier (Spec)) = Aspect_Name then |
| return Spec; |
| end if; |
| Next (Spec); |
| end loop; |
| |
| return Empty; |
| end Get_Aspect_Spec; |
| |
| -- Local variables |
| |
| Prev_Aspects : constant List_Id := |
| Aspect_Specifications (Parent (Def_Id)); |
| Par_Type : Entity_Id; |
| Prev_Aspect : Node_Id; |
| |
| -- Start of processing for Check_Nonoverridable_Aspects |
| |
| begin |
| -- Get parent type of derived type. Note that Prev is the entity in |
| -- the partial declaration, but its contents are now those of full |
| -- view, while Def_Id reflects the partial view. |
| |
| if Is_Private_Type (Def_Id) then |
| Par_Type := Etype (Full_View (Def_Id)); |
| else |
| Par_Type := Etype (Def_Id); |
| end if; |
| |
| -- If there is an inherited Implicit_Dereference, verify that it is |
| -- made explicit in the partial view. |
| |
| if Has_Discriminants (Base_Type (Par_Type)) |
| and then Nkind (Parent (Prev)) = N_Full_Type_Declaration |
| and then Present (Discriminant_Specifications (Parent (Prev))) |
| and then Present (Get_Reference_Discriminant (Par_Type)) |
| then |
| Prev_Aspect := |
| Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference); |
| |
| if No (Prev_Aspect) |
| and then Present |
| (Discriminant_Specifications |
| (Original_Node (Parent (Prev)))) |
| then |
| Error_Msg_N |
| ("type does not inherit implicit dereference", Prev); |
| |
| else |
| -- If one of the views has the aspect specified, verify that it |
| -- is consistent with that of the parent. |
| |
| declare |
| Cur_Discr : constant Entity_Id := |
| Get_Reference_Discriminant (Prev); |
| Par_Discr : constant Entity_Id := |
| Get_Reference_Discriminant (Par_Type); |
| |
| begin |
| if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then |
| Error_Msg_N |
| ("aspect inconsistent with that of parent", N); |
| end if; |
| |
| -- Check that specification in partial view matches the |
| -- inherited aspect. Compare names directly because aspect |
| -- expression may not be analyzed. |
| |
| if Present (Prev_Aspect) |
| and then Nkind (Expression (Prev_Aspect)) = N_Identifier |
| and then Chars (Expression (Prev_Aspect)) /= |
| Chars (Cur_Discr) |
| then |
| Error_Msg_N |
| ("aspect inconsistent with that of parent", N); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- What about other nonoverridable aspects??? |
| end Check_Nonoverridable_Aspects; |
| |
| ------------------------------------ |
| -- Check_Ops_From_Incomplete_Type -- |
| ------------------------------------ |
| |
| procedure Check_Ops_From_Incomplete_Type is |
| Elmt : Elmt_Id; |
| Formal : Entity_Id; |
| Op : Entity_Id; |
| |
| begin |
| if Prev /= T |
| and then Ekind (Prev) = E_Incomplete_Type |
| and then Is_Tagged_Type (Prev) |
| and then Is_Tagged_Type (T) |
| and then Present (Primitive_Operations (Prev)) |
| then |
| Elmt := First_Elmt (Primitive_Operations (Prev)); |
| while Present (Elmt) loop |
| Op := Node (Elmt); |
| |
| Formal := First_Formal (Op); |
| while Present (Formal) loop |
| if Etype (Formal) = Prev then |
| Set_Etype (Formal, T); |
| end if; |
| |
| Next_Formal (Formal); |
| end loop; |
| |
| if Etype (Op) = Prev then |
| Set_Etype (Op, T); |
| end if; |
| |
| Next_Elmt (Elmt); |
| end loop; |
| end if; |
| end Check_Ops_From_Incomplete_Type; |
| |
| -- Start of processing for Analyze_Full_Type_Declaration |
| |
| begin |
| Prev := Find_Type_Name (N); |
| |
| -- The full view, if present, now points to the current type. If there |
| -- is an incomplete partial view, set a link to it, to simplify the |
| -- retrieval of primitive operations of the type. |
| |
| -- Ada 2005 (AI-50217): If the type was previously decorated when |
| -- imported through a LIMITED WITH clause, it appears as incomplete |
| -- but has no full view. |
| |
| if Ekind (Prev) = E_Incomplete_Type |
| and then Present (Full_View (Prev)) |
| then |
| T := Full_View (Prev); |
| Set_Incomplete_View (N, Prev); |
| else |
| T := Prev; |
| end if; |
| |
| Set_Is_Pure (T, Is_Pure (Current_Scope)); |
| |
| -- We set the flag Is_First_Subtype here. It is needed to set the |
| -- corresponding flag for the Implicit class-wide-type created |
| -- during tagged types processing. |
| |
| Set_Is_First_Subtype (T, True); |
| |
| -- Only composite types other than array types are allowed to have |
| -- discriminants. |
| |
| case Nkind (Def) is |
| |
| -- For derived types, the rule will be checked once we've figured |
| -- out the parent type. |
| |
| when N_Derived_Type_Definition => |
| null; |
| |
| -- For record types, discriminants are allowed. |
| |
| when N_Record_Definition => |
| null; |
| |
| when others => |
| if Present (Discriminant_Specifications (N)) then |
| Error_Msg_N |
| ("elementary or array type cannot have discriminants", |
| Defining_Identifier |
| (First (Discriminant_Specifications (N)))); |
| end if; |
| end case; |
| |
| -- Elaborate the type definition according to kind, and generate |
| -- subsidiary (implicit) subtypes where needed. We skip this if it was |
| -- already done (this happens during the reanalysis that follows a call |
| -- to the high level optimizer). |
| |
| if not Analyzed (T) then |
| Set_Analyzed (T); |
| |
| -- Set the SPARK mode from the current context |
| |
| Set_SPARK_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (T); |
| |
| case Nkind (Def) is |
| when N_Access_To_Subprogram_Definition => |
| Access_Subprogram_Declaration (T, Def); |
| |
| -- If this is a remote access to subprogram, we must create the |
| -- equivalent fat pointer type, and related subprograms. |
| |
| if Is_Remote then |
| Process_Remote_AST_Declaration (N); |
| end if; |
| |
| -- Validate categorization rule against access type declaration |
| -- usually a violation in Pure unit, Shared_Passive unit. |
| |
| Validate_Access_Type_Declaration (T, N); |
| |
| -- If the type has contracts, we create the corresponding |
| -- wrapper at once, before analyzing the aspect specifications, |
| -- so that pre/postconditions can be handled directly on the |
| -- generated wrapper. |
| |
| if Ada_Version >= Ada_2022 |
| and then Present (Aspect_Specifications (N)) |
| then |
| Build_Access_Subprogram_Wrapper (N); |
| end if; |
| |
| when N_Access_To_Object_Definition => |
| Access_Type_Declaration (T, Def); |
| |
| -- Validate categorization rule against access type declaration |
| -- usually a violation in Pure unit, Shared_Passive unit. |
| |
| Validate_Access_Type_Declaration (T, N); |
| |
| -- If we are in a Remote_Call_Interface package and define a |
| -- RACW, then calling stubs and specific stream attributes |
| -- must be added. |
| |
| if Is_Remote |
| and then Is_Remote_Access_To_Class_Wide_Type (Def_Id) |
| then |
| Add_RACW_Features (Def_Id); |
| end if; |
| |
| when N_Array_Type_Definition => |
| Array_Type_Declaration (T, Def); |
| |
| when N_Derived_Type_Definition => |
| Derived_Type_Declaration (T, N, T /= Def_Id); |
| |
| -- Inherit predicates from parent, and protect against illegal |
| -- derivations. |
| |
| if Is_Type (T) and then Has_Predicates (T) then |
| Set_Has_Predicates (Def_Id); |
| end if; |
| |
| -- Save the scenario for examination by the ABE Processing |
| -- phase. |
| |
| Record_Elaboration_Scenario (N); |
| |
| when N_Enumeration_Type_Definition => |
| Enumeration_Type_Declaration (T, Def); |
| |
| when N_Floating_Point_Definition => |
| Floating_Point_Type_Declaration (T, Def); |
| |
| when N_Decimal_Fixed_Point_Definition => |
| Decimal_Fixed_Point_Type_Declaration (T, Def); |
| |
| when N_Ordinary_Fixed_Point_Definition => |
| Ordinary_Fixed_Point_Type_Declaration (T, Def); |
| |
| when N_Signed_Integer_Type_Definition => |
| Signed_Integer_Type_Declaration (T, Def); |
| |
| when N_Modular_Type_Definition => |
| Modular_Type_Declaration (T, Def); |
| |
| when N_Record_Definition => |
| Record_Type_Declaration (T, N, Prev); |
| |
| -- If declaration has a parse error, nothing to elaborate. |
| |
| when N_Error => |
| null; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end if; |
| |
| if Etype (T) = Any_Type then |
| return; |
| end if; |
| |
| -- Set the primitives list of the full type and its base type when |
| -- needed. T may be E_Void in cases of earlier errors, and in that |
| -- case we bypass this. |
| |
| if Ekind (T) /= E_Void then |
| if not Present (Direct_Primitive_Operations (T)) then |
| if Etype (T) = T then |
| Set_Direct_Primitive_Operations (T, New_Elmt_List); |
| |
| -- If Etype of T is the base type (as opposed to a parent type) |
| -- and already has an associated list of primitive operations, |
| -- then set T's primitive list to the base type's list. Otherwise, |
| -- create a new empty primitives list and share the list between |
| -- T and its base type. The lists need to be shared in common. |
| |
| elsif Etype (T) = Base_Type (T) then |
| |
| if not Present (Direct_Primitive_Operations (Base_Type (T))) |
| then |
| Set_Direct_Primitive_Operations |
| (Base_Type (T), New_Elmt_List); |
| end if; |
| |
| Set_Direct_Primitive_Operations |
| (T, Direct_Primitive_Operations (Base_Type (T))); |
| |
| -- Case where the Etype is a parent type, so we need a new |
| -- primitives list for T. |
| |
| else |
| Set_Direct_Primitive_Operations (T, New_Elmt_List); |
| end if; |
| |
| -- If T already has a Direct_Primitive_Operations list but its |
| -- base type doesn't then set the base type's list to T's list. |
| |
| elsif not Present (Direct_Primitive_Operations (Base_Type (T))) then |
| Set_Direct_Primitive_Operations |
| (Base_Type (T), Direct_Primitive_Operations (T)); |
| end if; |
| end if; |
| |
| -- Some common processing for all types |
| |
| Set_Depends_On_Private (T, Has_Private_Component (T)); |
| Check_Ops_From_Incomplete_Type; |
| |
| -- Both the declared entity, and its anonymous base type if one was |
| -- created, need freeze nodes allocated. |
| |
| declare |
| B : constant Entity_Id := Base_Type (T); |
| |
| begin |
| -- In the case where the base type differs from the first subtype, we |
| -- pre-allocate a freeze node, and set the proper link to the first |
| -- subtype. Freeze_Entity will use this preallocated freeze node when |
| -- it freezes the entity. |
| |
| -- This does not apply if the base type is a generic type, whose |
| -- declaration is independent of the current derived definition. |
| |
| if B /= T and then not Is_Generic_Type (B) then |
| Ensure_Freeze_Node (B); |
| Set_First_Subtype_Link (Freeze_Node (B), T); |
| end if; |
| |
| -- A type that is imported through a limited_with clause cannot |
| -- generate any code, and thus need not be frozen. However, an access |
| -- type with an imported designated type needs a finalization list, |
| -- which may be referenced in some other package that has non-limited |
| -- visibility on the designated type. Thus we must create the |
| -- finalization list at the point the access type is frozen, to |
| -- prevent unsatisfied references at link time. |
| |
| if not From_Limited_With (T) or else Is_Access_Type (T) then |
| Set_Has_Delayed_Freeze (T); |
| end if; |
| end; |
| |
| -- Case where T is the full declaration of some private type which has |
| -- been swapped in Defining_Identifier (N). |
| |
| if T /= Def_Id and then Is_Private_Type (Def_Id) then |
| Process_Full_View (N, T, Def_Id); |
| |
| -- Record the reference. The form of this is a little strange, since |
| -- the full declaration has been swapped in. So the first parameter |
| -- here represents the entity to which a reference is made which is |
| -- the "real" entity, i.e. the one swapped in, and the second |
| -- parameter provides the reference location. |
| |
| -- Also, we want to kill Has_Pragma_Unreferenced temporarily here |
| -- since we don't want a complaint about the full type being an |
| -- unwanted reference to the private type |
| |
| declare |
| B : constant Boolean := Has_Pragma_Unreferenced (T); |
| begin |
| Set_Has_Pragma_Unreferenced (T, False); |
| Generate_Reference (T, T, 'c'); |
| Set_Has_Pragma_Unreferenced (T, B); |
| end; |
| |
| Set_Completion_Referenced (Def_Id); |
| |
| -- For completion of incomplete type, process incomplete dependents |
| -- and always mark the full type as referenced (it is the incomplete |
| -- type that we get for any real reference). |
| |
| elsif Ekind (Prev) = E_Incomplete_Type then |
| Process_Incomplete_Dependents (N, T, Prev); |
| Generate_Reference (Prev, Def_Id, 'c'); |
| Set_Completion_Referenced (Def_Id); |
| |
| -- If not private type or incomplete type completion, this is a real |
| -- definition of a new entity, so record it. |
| |
| else |
| Generate_Definition (Def_Id); |
| end if; |
| |
| -- Propagate any pending access types whose finalization masters need to |
| -- be fully initialized from the partial to the full view. Guard against |
| -- an illegal full view that remains unanalyzed. |
| |
| if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then |
| Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev)); |
| end if; |
| |
| if Chars (Scope (Def_Id)) = Name_System |
| and then Chars (Def_Id) = Name_Address |
| and then In_Predefined_Unit (N) |
| then |
| Set_Is_Descendant_Of_Address (Def_Id); |
| Set_Is_Descendant_Of_Address (Base_Type (Def_Id)); |
| Set_Is_Descendant_Of_Address (Prev); |
| end if; |
| |
| Set_Optimize_Alignment_Flags (Def_Id); |
| Check_Eliminated (Def_Id); |
| |
| -- If the declaration is a completion and aspects are present, apply |
| -- them to the entity for the type which is currently the partial |
| -- view, but which is the one that will be frozen. |
| |
| if Has_Aspects (N) then |
| |
| -- In most cases the partial view is a private type, and both views |
| -- appear in different declarative parts. In the unusual case where |
| -- the partial view is incomplete, perform the analysis on the |
| -- full view, to prevent freezing anomalies with the corresponding |
| -- class-wide type, which otherwise might be frozen before the |
| -- dispatch table is built. |
| |
| if Prev /= Def_Id |
| and then Ekind (Prev) /= E_Incomplete_Type |
| then |
| Analyze_Aspect_Specifications (N, Prev); |
| |
| -- Normal case |
| |
| else |
| Analyze_Aspect_Specifications (N, Def_Id); |
| end if; |
| end if; |
| |
| if Is_Derived_Type (Prev) |
| and then Def_Id /= Prev |
| then |
| Check_Nonoverridable_Aspects; |
| end if; |
| |
| -- Check for tagged type declaration at library level |
| |
| if Is_Tagged_Type (T) |
| and then not Is_Library_Level_Entity (T) |
| then |
| Check_Restriction (No_Local_Tagged_Types, T); |
| end if; |
| end Analyze_Full_Type_Declaration; |
| |
| ---------------------------------- |
| -- Analyze_Incomplete_Type_Decl -- |
| ---------------------------------- |
| |
| procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is |
| F : constant Boolean := Is_Pure (Current_Scope); |
| T : Entity_Id; |
| |
| begin |
| Generate_Definition (Defining_Identifier (N)); |
| |
| -- Process an incomplete declaration. The identifier must not have been |
| -- declared already in the scope. However, an incomplete declaration may |
| -- appear in the private part of a package, for a private type that has |
| -- already been declared. |
| |
| -- In this case, the discriminants (if any) must match |
| |
| T := Find_Type_Name (N); |
| |
| Mutate_Ekind (T, E_Incomplete_Type); |
| Set_Etype (T, T); |
| Set_Is_First_Subtype (T); |
| Reinit_Size_Align (T); |
| |
| -- Set the SPARK mode from the current context |
| |
| Set_SPARK_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (T); |
| |
| -- Ada 2005 (AI-326): Minimum decoration to give support to tagged |
| -- incomplete types. |
| |
| if Tagged_Present (N) then |
| Set_Is_Tagged_Type (T, True); |
| Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); |
| Make_Class_Wide_Type (T); |
| end if; |
| |
| -- Initialize the list of primitive operations to an empty list, |
| -- to cover tagged types as well as untagged types. For untagged |
| -- types this is used either to analyze the call as legal when |
| -- Core_Extensions_Allowed is True, or to issue a better error message |
| -- otherwise. |
| |
| Set_Direct_Primitive_Operations (T, New_Elmt_List); |
| |
| Set_Stored_Constraint (T, No_Elist); |
| |
| if Present (Discriminant_Specifications (N)) then |
| Push_Scope (T); |
| Process_Discriminants (N); |
| End_Scope; |
| end if; |
| |
| -- If the type has discriminants, nontrivial subtypes may be declared |
| -- before the full view of the type. The full views of those subtypes |
| -- will be built after the full view of the type. |
| |
| Set_Private_Dependents (T, New_Elmt_List); |
| Set_Is_Pure (T, F); |
| end Analyze_Incomplete_Type_Decl; |
| |
| ----------------------------------- |
| -- Analyze_Interface_Declaration -- |
| ----------------------------------- |
| |
| procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is |
| CW : constant Entity_Id := Class_Wide_Type (T); |
| |
| begin |
| Set_Is_Tagged_Type (T); |
| Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); |
| |
| Set_Is_Limited_Record (T, Limited_Present (Def) |
| or else Task_Present (Def) |
| or else Protected_Present (Def) |
| or else Synchronized_Present (Def)); |
| |
| -- Type is abstract if full declaration carries keyword, or if previous |
| -- partial view did. |
| |
| Set_Is_Abstract_Type (T); |
| Set_Is_Interface (T); |
| |
| -- Type is a limited interface if it includes the keyword limited, task, |
| -- protected, or synchronized. |
| |
| Set_Is_Limited_Interface |
| (T, Limited_Present (Def) |
| or else Protected_Present (Def) |
| or else Synchronized_Present (Def) |
| or else Task_Present (Def)); |
| |
| Set_Interfaces (T, New_Elmt_List); |
| Set_Direct_Primitive_Operations (T, New_Elmt_List); |
| |
| -- Complete the decoration of the class-wide entity if it was already |
| -- built (i.e. during the creation of the limited view) |
| |
| if Present (CW) then |
| Set_Is_Interface (CW); |
| Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); |
| end if; |
| |
| -- Check runtime support for synchronized interfaces |
| |
| if Is_Concurrent_Interface (T) |
| and then not RTE_Available (RE_Select_Specific_Data) |
| then |
| Error_Msg_CRT ("synchronized interfaces", T); |
| end if; |
| end Analyze_Interface_Declaration; |
| |
| ----------------------------- |
| -- Analyze_Itype_Reference -- |
| ----------------------------- |
| |
| -- Nothing to do. This node is placed in the tree only for the benefit of |
| -- back end processing, and has no effect on the semantic processing. |
| |
| procedure Analyze_Itype_Reference (N : Node_Id) is |
| begin |
| pragma Assert (Is_Itype (Itype (N))); |
| null; |
| end Analyze_Itype_Reference; |
| |
| -------------------------------- |
| -- Analyze_Number_Declaration -- |
| -------------------------------- |
| |
| procedure Analyze_Number_Declaration (N : Node_Id) is |
| E : constant Node_Id := Expression (N); |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Index : Interp_Index; |
| It : Interp; |
| T : Entity_Id; |
| |
| begin |
| Generate_Definition (Id); |
| Enter_Name (Id); |
| |
| -- This is an optimization of a common case of an integer literal |
| |
| if Nkind (E) = N_Integer_Literal then |
| Set_Is_Static_Expression (E, True); |
| Set_Etype (E, Universal_Integer); |
| |
| Set_Etype (Id, Universal_Integer); |
| Mutate_Ekind (Id, E_Named_Integer); |
| Set_Is_Frozen (Id, True); |
| |
| Set_Debug_Info_Needed (Id); |
| return; |
| end if; |
| |
| Set_Is_Pure (Id, Is_Pure (Current_Scope)); |
| |
| -- Process expression, replacing error by integer zero, to avoid |
| -- cascaded errors or aborts further along in the processing |
| |
| -- Replace Error by integer zero, which seems least likely to cause |
| -- cascaded errors. |
| |
| if E = Error then |
| Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); |
| Set_Error_Posted (E); |
| end if; |
| |
| Analyze (E); |
| |
| -- Verify that the expression is static and numeric. If |
| -- the expression is overloaded, we apply the preference |
| -- rule that favors root numeric types. |
| |
| if not Is_Overloaded (E) then |
| T := Etype (E); |
| if Has_Dynamic_Predicate_Aspect (T) then |
| Error_Msg_N |
| ("subtype has dynamic predicate, " |
| & "not allowed in number declaration", N); |
| end if; |
| |
| else |
| T := Any_Type; |
| |
| Get_First_Interp (E, Index, It); |
| while Present (It.Typ) loop |
| if (Is_Integer_Type (It.Typ) or else Is_Real_Type (It.Typ)) |
| and then (Scope (Base_Type (It.Typ))) = Standard_Standard |
| then |
| if T = Any_Type then |
| T := It.Typ; |
| |
| elsif Is_Universal_Numeric_Type (It.Typ) then |
| -- Choose universal interpretation over any other |
| |
| T := It.Typ; |
| exit; |
| end if; |
| end if; |
| |
| Get_Next_Interp (Index, It); |
| end loop; |
| end if; |
| |
| if Is_Integer_Type (T) then |
| Resolve (E, T); |
| Set_Etype (Id, Universal_Integer); |
| Mutate_Ekind (Id, E_Named_Integer); |
| |
| elsif Is_Real_Type (T) then |
| |
| -- Because the real value is converted to universal_real, this is a |
| -- legal context for a universal fixed expression. |
| |
| if T = Universal_Fixed then |
| declare |
| Loc : constant Source_Ptr := Sloc (N); |
| Conv : constant Node_Id := Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Universal_Real, Loc), |
| Expression => Relocate_Node (E)); |
| |
| begin |
| Rewrite (E, Conv); |
| Analyze (E); |
| end; |
| |
| elsif T = Any_Fixed then |
| Error_Msg_N ("illegal context for mixed mode operation", E); |
| |
| -- Expression is of the form : universal_fixed * integer. Try to |
| -- resolve as universal_real. |
| |
| T := Universal_Real; |
| Set_Etype (E, T); |
| end if; |
| |
| Resolve (E, T); |
| Set_Etype (Id, Universal_Real); |
| Mutate_Ekind (Id, E_Named_Real); |
| |
| else |
| Wrong_Type (E, Any_Numeric); |
| Resolve (E, T); |
| |
| Set_Etype (Id, T); |
| Mutate_Ekind (Id, E_Constant); |
| Set_Never_Set_In_Source (Id, True); |
| Set_Is_True_Constant (Id, True); |
| return; |
| end if; |
| |
| if Nkind (E) in N_Integer_Literal | N_Real_Literal then |
| Set_Etype (E, Etype (Id)); |
| end if; |
| |
| if not Is_OK_Static_Expression (E) then |
| Flag_Non_Static_Expr |
| ("non-static expression used in number declaration!", E); |
| Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); |
| Set_Etype (E, Any_Type); |
| end if; |
| |
| Analyze_Dimension (N); |
| end Analyze_Number_Declaration; |
| |
| -------------------------------- |
| -- Analyze_Object_Declaration -- |
| -------------------------------- |
| |
| -- WARNING: This routine manages Ghost regions. Return statements must be |
| -- replaced by gotos which jump to the end of the routine and restore the |
| -- Ghost mode. |
| |
| procedure Analyze_Object_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Next_Decl : constant Node_Id := Next (N); |
| |
| Act_T : Entity_Id; |
| T : Entity_Id; |
| |
| E : Node_Id := Expression (N); |
| -- E is set to Expression (N) throughout this routine. When Expression |
| -- (N) is modified, E is changed accordingly. |
| |
| procedure Check_Dynamic_Object (Typ : Entity_Id); |
| -- A library-level object with nonstatic discriminant constraints may |
| -- require dynamic allocation. The declaration is illegal if the |
| -- profile includes the restriction No_Implicit_Heap_Allocations. |
| |
| procedure Check_For_Null_Excluding_Components |
| (Obj_Typ : Entity_Id; |
| Obj_Decl : Node_Id); |
| -- Verify that each null-excluding component of object declaration |
| -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit |
| -- a compile-time warning if this is not the case. |
| |
| function Count_Tasks (T : Entity_Id) return Uint; |
| -- This function is called when a non-generic library level object of a |
| -- task type is declared. Its function is to count the static number of |
| -- tasks declared within the type (it is only called if Has_Task is set |
| -- for T). As a side effect, if an array of tasks with nonstatic bounds |
| -- or a variant record type is encountered, Check_Restriction is called |
| -- indicating the count is unknown. |
| |
| function Delayed_Aspect_Present return Boolean; |
| -- If the declaration has an expression that is an aggregate, and it |
| -- has aspects that require delayed analysis, the resolution of the |
| -- aggregate must be deferred to the freeze point of the object. This |
| -- special processing was created for address clauses, but it must |
| -- also apply to address aspects. This must be done before the aspect |
| -- specifications are analyzed because we must handle the aggregate |
| -- before the analysis of the object declaration is complete. |
| |
| -- Any other relevant delayed aspects on object declarations ??? |
| |
| -------------------------- |
| -- Check_Dynamic_Object -- |
| -------------------------- |
| |
| procedure Check_Dynamic_Object (Typ : Entity_Id) is |
| Comp : Entity_Id; |
| Obj_Type : Entity_Id; |
| |
| begin |
| Obj_Type := Typ; |
| |
| if Is_Private_Type (Obj_Type) |
| and then Present (Full_View (Obj_Type)) |
| then |
| Obj_Type := Full_View (Obj_Type); |
| end if; |
| |
| if Known_Static_Esize (Obj_Type) then |
| return; |
| end if; |
| |
| if Restriction_Active (No_Implicit_Heap_Allocations) |
| and then Expander_Active |
| and then Has_Discriminants (Obj_Type) |
| then |
| Comp := First_Component (Obj_Type); |
| while Present (Comp) loop |
| if Known_Static_Esize (Etype (Comp)) |
| or else Size_Known_At_Compile_Time (Etype (Comp)) |
| then |
| null; |
| |
| elsif Is_Record_Type (Etype (Comp)) then |
| Check_Dynamic_Object (Etype (Comp)); |
| |
| elsif not Discriminated_Size (Comp) |
| and then Comes_From_Source (Comp) |
| then |
| Error_Msg_NE |
| ("component& of non-static size will violate restriction " |
| & "No_Implicit_Heap_Allocation?", N, Comp); |
| |
| end if; |
| |
| Next_Component (Comp); |
| end loop; |
| end if; |
| end Check_Dynamic_Object; |
| |
| ----------------------------------------- |
| -- Check_For_Null_Excluding_Components -- |
| ----------------------------------------- |
| |
| procedure Check_For_Null_Excluding_Components |
| (Obj_Typ : Entity_Id; |
| Obj_Decl : Node_Id) |
| is |
| procedure Check_Component |
| (Comp_Typ : Entity_Id; |
| Comp_Decl : Node_Id := Empty; |
| Array_Comp : Boolean := False); |
| -- Apply a compile-time null-exclusion check on a component denoted |
| -- by its declaration Comp_Decl and type Comp_Typ, and all of its |
| -- subcomponents (if any). |
| |
| --------------------- |
| -- Check_Component -- |
| --------------------- |
| |
| procedure Check_Component |
| (Comp_Typ : Entity_Id; |
| Comp_Decl : Node_Id := Empty; |
| Array_Comp : Boolean := False) |
| is |
| Comp : Entity_Id; |
| T : Entity_Id; |
| |
| begin |
| -- Do not consider internally-generated components or those that |
| -- are already initialized. |
| |
| if Present (Comp_Decl) |
| and then (not Comes_From_Source (Comp_Decl) |
| or else Present (Expression (Comp_Decl))) |
| then |
| return; |
| end if; |
| |
| if Is_Incomplete_Or_Private_Type (Comp_Typ) |
| and then Present (Full_View (Comp_Typ)) |
| then |
| T := Full_View (Comp_Typ); |
| else |
| T := Comp_Typ; |
| end if; |
| |
| -- Verify a component of a null-excluding access type |
| |
| if Is_Access_Type (T) |
| and then Can_Never_Be_Null (T) |
| then |
| if Comp_Decl = Obj_Decl then |
| Null_Exclusion_Static_Checks |
| (N => Obj_Decl, |
| Comp => Empty, |
| Array_Comp => Array_Comp); |
| |
| else |
| Null_Exclusion_Static_Checks |
| (N => Obj_Decl, |
| Comp => Comp_Decl, |
| Array_Comp => Array_Comp); |
| end if; |
| |
| -- Check array components |
| |
| elsif Is_Array_Type (T) then |
| |
| -- There is no suitable component when the object is of an |
| -- array type. However, a namable component may appear at some |
| -- point during the recursive inspection, but not at the top |
| -- level. At the top level just indicate array component case. |
| |
| if Comp_Decl = Obj_Decl then |
| Check_Component (Component_Type (T), Array_Comp => True); |
| else |
| Check_Component (Component_Type (T), Comp_Decl); |
| end if; |
| |
| -- Verify all components of type T |
| |
| -- Note: No checks are performed on types with discriminants due |
| -- to complexities involving variants. ??? |
| |
| elsif (Is_Concurrent_Type (T) |
| or else Is_Incomplete_Or_Private_Type (T) |
| or else Is_Record_Type (T)) |
| and then not Has_Discriminants (T) |
| then |
| Comp := First_Component (T); |
| while Present (Comp) loop |
| Check_Component (Etype (Comp), Parent (Comp)); |
| |
| Next_Component (Comp); |
| end loop; |
| end if; |
| end Check_Component; |
| |
| -- Start processing for Check_For_Null_Excluding_Components |
| |
| begin |
| Check_Component (Obj_Typ, Obj_Decl); |
| end Check_For_Null_Excluding_Components; |
| |
| ----------------- |
| -- Count_Tasks -- |
| ----------------- |
| |
| function Count_Tasks (T : Entity_Id) return Uint is |
| C : Entity_Id; |
| X : Node_Id; |
| V : Uint; |
| |
| begin |
| if Is_Task_Type (T) then |
| return Uint_1; |
| |
| elsif Is_Record_Type (T) then |
| if Has_Discriminants (T) then |
| Check_Restriction (Max_Tasks, N); |
| return Uint_0; |
| |
| else |
| V := Uint_0; |
| C := First_Component (T); |
| while Present (C) loop |
| V := V + Count_Tasks (Etype (C)); |
| Next_Component (C); |
| end loop; |
| |
| return V; |
| end if; |
| |
| elsif Is_Array_Type (T) then |
| X := First_Index (T); |
| V := Count_Tasks (Component_Type (T)); |
| while Present (X) loop |
| C := Etype (X); |
| |
| if not Is_OK_Static_Subtype (C) then |
| Check_Restriction (Max_Tasks, N); |
| return Uint_0; |
| else |
| V := V * (UI_Max (Uint_0, |
| Expr_Value (Type_High_Bound (C)) - |
| Expr_Value (Type_Low_Bound (C)) + Uint_1)); |
| end if; |
| |
| Next_Index (X); |
| end loop; |
| |
| return V; |
| |
| else |
| return Uint_0; |
| end if; |
| end Count_Tasks; |
| |
| ---------------------------- |
| -- Delayed_Aspect_Present -- |
| ---------------------------- |
| |
| function Delayed_Aspect_Present return Boolean is |
| A : Node_Id; |
| A_Id : Aspect_Id; |
| |
| begin |
| if Present (Aspect_Specifications (N)) then |
| A := First (Aspect_Specifications (N)); |
| |
| while Present (A) loop |
| A_Id := Get_Aspect_Id (Chars (Identifier (A))); |
| |
| if A_Id = Aspect_Address then |
| |
| -- Set flag on object entity, for later processing at |
| -- the freeze point. |
| |
| Set_Has_Delayed_Aspects (Id); |
| return True; |
| end if; |
| |
| Next (A); |
| end loop; |
| end if; |
| |
| return False; |
| end Delayed_Aspect_Present; |
| |
| -- Local variables |
| |
| Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
| Saved_IGR : constant Node_Id := Ignored_Ghost_Region; |
| -- Save the Ghost-related attributes to restore on exit |
| |
| Prev_Entity : Entity_Id := Empty; |
| Related_Id : Entity_Id; |
| |
| -- Start of processing for Analyze_Object_Declaration |
| |
| begin |
| -- There are three kinds of implicit types generated by an |
| -- object declaration: |
| |
| -- 1. Those generated by the original Object Definition |
| |
| -- 2. Those generated by the Expression |
| |
| -- 3. Those used to constrain the Object Definition with the |
| -- expression constraints when the definition is unconstrained. |
| |
| -- They must be generated in this order to avoid order of elaboration |
| -- issues. Thus the first step (after entering the name) is to analyze |
| -- the object definition. |
| |
| if Constant_Present (N) then |
| Prev_Entity := Current_Entity_In_Scope (Id); |
| |
| if Present (Prev_Entity) |
| and then |
| -- If the homograph is an implicit subprogram, it is overridden |
| -- by the current declaration. |
| |
| ((Is_Overloadable (Prev_Entity) |
| and then Is_Inherited_Operation (Prev_Entity)) |
| |
| -- The current object is a discriminal generated for an entry |
| -- family index. Even though the index is a constant, in this |
| -- particular context there is no true constant redeclaration. |
| -- Enter_Name will handle the visibility. |
| |
| or else |
| (Is_Discriminal (Id) |
| and then Ekind (Discriminal_Link (Id)) = |
| E_Entry_Index_Parameter) |
| |
| -- The current object is the renaming for a generic declared |
| -- within the instance. |
| |
| or else |
| (Ekind (Prev_Entity) = E_Package |
| and then Nkind (Parent (Prev_Entity)) = |
| N_Package_Renaming_Declaration |
| and then not Comes_From_Source (Prev_Entity) |
| and then |
| Is_Generic_Instance (Renamed_Entity (Prev_Entity))) |
| |
| -- The entity may be a homonym of a private component of the |
| -- enclosing protected object, for which we create a local |
| -- renaming declaration. The declaration is legal, even if |
| -- useless when it just captures that component. |
| |
| or else |
| (Ekind (Scope (Current_Scope)) = E_Protected_Type |
| and then Nkind (Parent (Prev_Entity)) = |
| N_Object_Renaming_Declaration)) |
| then |
| Prev_Entity := Empty; |
| end if; |
| end if; |
| |
| if Present (Prev_Entity) then |
| |
| -- The object declaration is Ghost when it completes a deferred Ghost |
| -- constant. |
| |
| Mark_And_Set_Ghost_Completion (N, Prev_Entity); |
| |
| Constant_Redeclaration (Id, N, T); |
| |
| Generate_Reference (Prev_Entity, Id, 'c'); |
| Set_Completion_Referenced (Id); |
| |
| if Error_Posted (N) then |
| |
| -- Type mismatch or illegal redeclaration; do not analyze |
| -- expression to avoid cascaded errors. |
| |
| T := Find_Type_Of_Object (Object_Definition (N), N); |
| Set_Etype (Id, T); |
| Mutate_Ekind (Id, E_Variable); |
| goto Leave; |
| end if; |
| |
| -- In the normal case, enter identifier at the start to catch premature |
| -- usage in the initialization expression. |
| |
| else |
| Generate_Definition (Id); |
| Enter_Name (Id); |
| |
| Mark_Coextensions (N, Object_Definition (N)); |
| |
| T := Find_Type_Of_Object (Object_Definition (N), N); |
| |
| if Nkind (Object_Definition (N)) = N_Access_Definition |
| and then Present |
| (Access_To_Subprogram_Definition (Object_Definition (N))) |
| and then Protected_Present |
| (Access_To_Subprogram_Definition (Object_Definition (N))) |
| then |
| T := Replace_Anonymous_Access_To_Protected_Subprogram (N); |
| end if; |
| |
| if Error_Posted (Id) then |
| Set_Etype (Id, T); |
| Mutate_Ekind (Id, E_Variable); |
| goto Leave; |
| end if; |
| end if; |
| |
| -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry |
| -- out some static checks. |
| |
| if Ada_Version >= Ada_2005 then |
| |
| -- In case of aggregates we must also take care of the correct |
| -- initialization of nested aggregates bug this is done at the |
| -- point of the analysis of the aggregate (see sem_aggr.adb) ??? |
| |
| if Can_Never_Be_Null (T) then |
| if Present (Expression (N)) |
| and then Nkind (Expression (N)) = N_Aggregate |
| then |
| null; |
| |
| elsif Comes_From_Source (Id) then |
| declare |
| Save_Typ : constant Entity_Id := Etype (Id); |
| begin |
| Set_Etype (Id, T); -- Temp. decoration for static checks |
| Null_Exclusion_Static_Checks (N); |
| Set_Etype (Id, Save_Typ); |
| end; |
| end if; |
| |
| -- We might be dealing with an object of a composite type containing |
| -- null-excluding components without an aggregate, so we must verify |
| -- that such components have default initialization. |
| |
| else |
| Check_For_Null_Excluding_Components (T, N); |
| end if; |
| end if; |
| |
| -- Object is marked pure if it is in a pure scope |
| |
| Set_Is_Pure (Id, Is_Pure (Current_Scope)); |
| |
| -- If deferred constant, make sure context is appropriate. We detect |
| -- a deferred constant as a constant declaration with no expression. |
| -- A deferred constant can appear in a package body if its completion |
| -- is by means of an interface pragma. |
| |
| if Constant_Present (N) and then No (E) then |
| |
| -- A deferred constant may appear in the declarative part of the |
| -- following constructs: |
| |
| -- blocks |
| -- entry bodies |
| -- extended return statements |
| -- package specs |
| -- package bodies |
| -- subprogram bodies |
| -- task bodies |
| |
| -- When declared inside a package spec, a deferred constant must be |
| -- completed by a full constant declaration or pragma Import. In all |
| -- other cases, the only proper completion is pragma Import. Extended |
| -- return statements are flagged as invalid contexts because they do |
| -- not have a declarative part and so cannot accommodate the pragma. |
| |
| if Ekind (Current_Scope) = E_Return_Statement then |
| Error_Msg_N |
| ("invalid context for deferred constant declaration (RM 7.4)", |
| N); |
| Error_Msg_N |
| ("\declaration requires an initialization expression", |
| N); |
| Set_Constant_Present (N, False); |
| |
| -- In Ada 83, deferred constant must be of private type |
| |
| elsif not Is_Private_Type (T) then |
| if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
| Error_Msg_N |
| ("(Ada 83) deferred constant must be private type", N); |
| end if; |
| end if; |
| |