-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Elists; use Elists;
with Einfo; use Einfo;
with Errout; use Errout;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
-- Local Subprograms --
-----------------------
- procedure Add_Interface_Tag_Components
- (N : Node_Id; Typ : Entity_Id);
+ 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.
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 (ie 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).
+ -- 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
+ -- (ie 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)?
(N : Node_Id;
Parent_Type : Entity_Id;
Derived_Type : Entity_Id);
- -- Subsidiary procedure to Build_Derived_Type. For a derived task or pro-
- -- tected type, inherit entries and protected subprograms, check legality
- -- of discriminant constraints if any.
+ -- 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;
Derive_Subps : Boolean := True);
- -- Subsidiary procedure to Build_Derived_Type and
+ -- Subsidiary procedure for Build_Derived_Type and
-- Analyze_Private_Extension_Declaration used for tagged and untagged
-- record types. 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
-- False is for an implicit derived full type for a type derived from a
-- private type (see Build_Derived_Type).
- procedure Collect_Interfaces
- (N : Node_Id;
- Derived_Type : Entity_Id);
- -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
- -- Collect the list of interfaces that are not already implemented by the
- -- ancestors. This is the list of interfaces for which we must provide
- -- additional tag components.
-
- procedure Complete_Subprograms_Derivation
- (Partial_View : Entity_Id;
- Derived_Type : Entity_Id);
- -- Ada 2005 (AI-251): Used to complete type derivation of private tagged
- -- types implementing interfaces. In this case some interface primitives
- -- may have been overriden with the partial-view and, instead of
- -- re-calculating them, they are included in the list of primitive
- -- operations of the full-view.
-
- 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.
-
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
Derived_Def : Boolean := False) return Elist_Id;
-- Validate discriminant constraints, and return the list of the
-- constraints in order of discriminant declarations. 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 if we are 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.
+ -- discriminated unconstrained type. Def is the N_Subtype_Indication node
+ -- where the discriminants constraints for T are specified. Derived_Def is
+ -- True if we are 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;
-- .. 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
+ -- 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.
(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.
+ -- 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;
-- of For_Access.
procedure Constrain_Enumeration (Def_Id : Node_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.
+ -- 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 : Node_Id; S : Node_Id);
-- Constrain a floating point type with either a digits constraint
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.
+ -- 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_Interface_Subprograms
- (Derived_Type : Entity_Id);
- -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
- -- Traverse the list of implemented interfaces and derive all their
- -- subprograms.
+ (Parent_Type : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Ifaces_List : Elist_Id);
+ -- Ada 2005 (AI-251): Derive primitives of abstract interface types that
+ -- are not immediate ancestors of Tagged type and associate them their
+ -- aliased primitive. Ifaces_List contains the abstract interface
+ -- primitives that have been derived from Parent_Type.
procedure Derived_Standard_Character
(N : Node_Id;
-- Build_Derived_Type 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.
+ -- 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.
+ -- 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 (ie 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.
+ -- 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;
-- 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_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).
+ -- 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 and is
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.
+ -- Create a new ordinary fixed point type, and apply the constraint to
+ -- obtain subtype of it.
procedure Prepare_Private_Subtype_Completion
(Id : Entity_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.
+ -- 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
(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.
+ -- 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 Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new signed integer entity, and apply the constraint to obtain
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Anon_Type : constant Entity_Id :=
- Create_Itype (E_Anonymous_Access_Type, Related_Nod,
- Scope_Id => Scope (Current_Scope));
+ Loc : constant Source_Ptr := Sloc (Related_Nod);
+ Anon_Type : Entity_Id;
Desig_Type : Entity_Id;
+ Decl : Entity_Id;
begin
if Is_Entry (Current_Scope)
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
- -- Ada 2005: for an object declaration, the corresponding anonymous
- -- type is declared in the current scope. For access formals, access
- -- components, and access discriminants, the scope is that of the
- -- enclosing declaration, as set above.
+ -- 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.
- if Nkind (Related_Nod) = N_Object_Declaration then
- Set_Scope (Anon_Type, Current_Scope);
+ if Nkind (Related_Nod) = N_Object_Declaration
+ or else Nkind (Related_Nod) = N_Access_Function_Definition
+ then
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Current_Scope);
+
+ -- 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.
+
+ elsif Nkind (Related_Nod) = N_Function_Specification
+ and then Nkind (Parent (N)) /= N_Parameter_Specification
+ then
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Scope (Defining_Unit_Name (Related_Nod)));
+
+ else
+ -- For access formals, access components, and access
+ -- discriminants, the scope is that of the enclosing declaration,
+
+ Anon_Type :=
+ Create_Itype
+ (E_Anonymous_Access_Type, Related_Nod,
+ Scope_Id => Scope (Current_Scope));
end if;
if All_Present (N)
Set_Has_Delayed_Freeze (Current_Scope);
end if;
+ -- Ada 2005: if the designated type is an interface that may contain
+ -- tasks, 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 Nkind (Related_Nod) = N_Object_Declaration
+ and then Expander_Active
+ then
+ if Is_Interface (Desig_Type)
+ and then Is_Limited_Record (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
+ if not Has_Master_Entity (Current_Scope) then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uMaster),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Master_Id), Loc),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (RTE (RE_Current_Master), Loc)));
+
+ Insert_Before (Related_Nod, Decl);
+ Analyze (Decl);
+
+ Set_Master_Id (Anon_Type, Defining_Identifier (Decl));
+ Set_Has_Master_Entity (Current_Scope);
+ else
+ Build_Master_Renaming (Related_Nod, Anon_Type);
+ end if;
+ end if;
+ end if;
+
return Anon_Type;
end Access_Definition;
is
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));
- D_Ityp : Node_Id := Associated_Node_For_Itype (Desig_Type);
begin
-- Associate the Itype node with the inner full-type declaration
-- (Y : access procedure
-- (Z : access T)))
+ D_Ityp := Associated_Node_For_Itype (Desig_Type);
while Nkind (D_Ityp) /= N_Full_Type_Declaration
and then Nkind (D_Ityp) /= N_Procedure_Specification
and then Nkind (D_Ityp) /= N_Function_Specification
if Nkind (D_Ityp) = N_Procedure_Specification
or else Nkind (D_Ityp) = N_Function_Specification
then
- Set_Scope (Desig_Type, Scope (Defining_Unit_Name (D_Ityp)));
+ Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
elsif Nkind (D_Ityp) = N_Full_Type_Declaration
or else Nkind (D_Ityp) = N_Object_Declaration
end if;
if Nkind (T_Def) = N_Access_Function_Definition then
- Analyze (Subtype_Mark (T_Def));
- Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def)));
+ if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
+ Set_Etype
+ (Desig_Type,
+ Access_Definition (T_Def, Result_Definition (T_Def)));
+ else
+ Analyze (Result_Definition (T_Def));
+ Set_Etype (Desig_Type, Entity (Result_Definition (T_Def)));
+ end if;
if not (Is_Type (Etype (Desig_Type))) then
Error_Msg_N
- ("expect type in function specification", Subtype_Mark (T_Def));
+ ("expect type in function specification",
+ Result_Definition (T_Def));
end if;
else
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
if Base_Type (Designated_Type (T)) = 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 (Designated_Type (T))
+ and then Etype (Designated_Type (T)) = T
+ then
+ Error_Msg_N
+ ("access type cannot designate its own classwide type", S);
+
+ -- Clean up indication of tagged status to prevent cascaded errors
+
+ Set_Is_Tagged_Type (T, False);
end if;
Set_Etype (T, T);
then
Set_From_With_Type (T);
- if Ekind (Desig) = E_Incomplete_Type then
+ if Is_Incomplete_Type (Desig) then
N_Desig := Non_Limited_View (Desig);
else pragma Assert (Ekind (Desig) = E_Class_Wide_Type);
-- Add_Interface_Tag_Components --
----------------------------------
- procedure Add_Interface_Tag_Components
- (N : Node_Id;
- Typ : Entity_Id)
- is
+ procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Elmt : Elmt_Id;
Ext : Node_Id;
Comp : Node_Id;
procedure Add_Tag (Iface : Entity_Id);
- -- Comment required ???
+ -- Add tag for one of the progenitor interfaces
-------------
-- Add_Tag --
-------------
procedure Add_Tag (Iface : Entity_Id) is
- Def : Node_Id;
- Tag : Entity_Id;
- Decl : Node_Id;
+ Decl : Node_Id;
+ Def : Node_Id;
+ Tag : Entity_Id;
+ Offset : Entity_Id;
begin
pragma Assert (Is_Tagged_Type (Iface)
Set_DT_Entry_Count (Tag,
DT_Entry_Count (First_Entity (Iface)));
- if not Present (Last_Tag) then
+ 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_Defining_Identifier (Loc, New_Internal_Name ('V'));
+
+ Decl :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Offset,
+ Component_Definition => Def);
+
+ Analyze_Component_Declaration (Decl);
+
+ Set_Analyzed (Decl);
+ Set_Ekind (Offset, E_Component);
+ Init_Component_Location (Offset);
+ Insert_After (Last_Tag, Decl);
+ Last_Tag := Decl;
+ end if;
end Add_Tag;
- -- Start of procesing for Add_Interface_Tag_Components
+ -- Start of processing for Add_Interface_Tag_Components
begin
if Ekind (Typ) /= E_Record_Type
- or else not Present (Abstract_Interfaces (Typ))
+ or else No (Abstract_Interfaces (Typ))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ or else not RTE_Available (RE_Interface_Tag)
then
return;
end if;
-- Find the last tag component
Comp := First (L);
-
while Present (Comp) loop
if Is_Tag (Defining_Identifier (Comp)) then
Last_Tag := Comp;
-- 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 --
------------------
when N_Index_Or_Discriminant_Constraint =>
declare
- IDC : Node_Id := First (Constraints (Constr));
+ IDC : Node_Id;
begin
+ IDC := First (Constraints (Constr));
while Present (IDC) loop
- -- One per-object constraint is sufficent
+ -- One per-object constraint is sufficient
if Contains_POC (IDC) then
return True;
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.
+
+ elsif R /= P
+ and then Is_Limited_Record (P)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Known_Limited;
+
-- Start of processing for Analyze_Component_Declaration
begin
end if;
-- If the subtype is a constrained subtype of the enclosing record,
- -- (which must have a partial view) the back-end does not handle
- -- properly the recursion. Rewrite the component declaration with an
+ -- (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 Present (Expression (N)) then
Analyze_Per_Use_Expression (Expression (N), T);
Check_Initialization (T, Expression (N));
+
+ if Ada_Version >= Ada_05
+ and then Is_Access_Type (T)
+ and then Ekind (T) = E_Anonymous_Access_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 (Expression (N)))) =
+ E_Class_Wide_Type
+ then
+ Error_Msg_N
+ ("access to specific tagged type required ('R'M 3.9.2(9))",
+ Expression (N));
+ end if;
+
+ -- (Ada 2005: AI-230): Accessibility check for anonymous
+ -- components
+
+ -- Missing barrier Ada_Version >= Ada_05???
+
+ if Type_Access_Level (Etype (Expression (N))) >
+ Type_Access_Level (T)
+ then
+ Error_Msg_N
+ ("expression has deeper access level than component " &
+ "('R'M 3.10.2 (12.2))", Expression (N));
+ end if;
+ end if;
end if;
-- The parent type may be a private view with unknown discriminants,
-- out some static checks.
if Ada_Version >= Ada_05
- and then (Null_Exclusion_Present (Component_Definition (N))
- or else Can_Never_Be_Null (T))
+ and then Can_Never_Be_Null (T)
then
- Set_Can_Never_Be_Null (Id);
Null_Exclusion_Static_Checks (N);
end if;
P := Private_Component (T);
if Present (P) then
+
-- Check for circular definitions
if P = Any_Type then
and then Is_Tagged_Type (Current_Scope)
then
if Is_Derived_Type (Current_Scope)
- and then not Is_Limited_Record (Root_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);
procedure Analyze_Declarations (L : List_Id) is
D : Node_Id;
- Next_Node : Node_Id;
Freeze_From : Entity_Id := Empty;
+ Next_Node : Node_Id;
procedure Adjust_D;
-- Adjust D not to include implicit label declarations, since these
Init_Size_Align (T);
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
+
+ -- Ada 2005 (AI-326): Minimum decoration to give support to tagged
+ -- incomplete types.
+
+ if Tagged_Present (N) then
+ Set_Is_Tagged_Type (T);
+ Make_Class_Wide_Type (T);
+ Set_Primitive_Operations (T, New_Elmt_List);
+ end if;
+
New_Scope (T);
Set_Stored_Constraint (T, No_Elist);
Set_Is_Pure (T, F);
end Analyze_Incomplete_Type_Decl;
+ -----------------------------------
+ -- Analyze_Interface_Declaration --
+ -----------------------------------
+
+ procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
+ begin
+ Set_Is_Tagged_Type (T);
+
+ 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 (T);
+ Set_Is_Interface (T);
+
+ Set_Is_Limited_Interface (T, Limited_Present (Def));
+ Set_Is_Protected_Interface (T, Protected_Present (Def));
+ Set_Is_Synchronized_Interface (T, Synchronized_Present (Def));
+ Set_Is_Task_Interface (T, Task_Present (Def));
+ Set_Abstract_Interfaces (T, New_Elmt_List);
+ Set_Primitive_Operations (T, New_Elmt_List);
+ end Analyze_Interface_Declaration;
+
-----------------------------
-- Analyze_Itype_Reference --
-----------------------------
- -- Nothing to do. This node is placed in the tree only for the benefit
- -- of Gigi processing, and has no effect on the semantic processing.
+ -- 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
else
T := Any_Type;
- Get_First_Interp (E, Index, It);
+ Get_First_Interp (E, Index, It);
while Present (It.Typ) loop
if (Is_Integer_Type (It.Typ)
or else Is_Real_Type (It.Typ))
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.
+ -- 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
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.
+ -- Expression is of the form : universal_fixed * integer. Try to
+ -- resolve as universal_real.
T := Universal_Real;
Set_Etype (E, T);
Prev_Entity : Entity_Id := Empty;
- function Build_Default_Subtype return Entity_Id;
- -- If the object is limited or aliased, and if the type is unconstrained
- -- and there is no expression, the discriminants cannot be modified and
- -- the subtype of the object is constrained by the defaults, so it is
- -- worthile building the corresponding subtype.
-
function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a library level object of type is
-- declared. It's function is to count the static number of tasks
-- a variant record type is encountered, Check_Restrictions is called
-- indicating the count is unknown.
- ---------------------------
- -- Build_Default_Subtype --
- ---------------------------
-
- function Build_Default_Subtype return Entity_Id is
- Constraints : constant List_Id := New_List;
- Act : Entity_Id;
- Decl : Node_Id;
- Disc : Entity_Id;
-
- begin
- Disc := First_Discriminant (T);
-
- if No (Discriminant_Default_Value (Disc)) then
- return T; -- previous error.
- end if;
-
- Act := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- while Present (Disc) loop
- Append (
- New_Copy_Tree (
- Discriminant_Default_Value (Disc)), Constraints);
- Next_Discriminant (Disc);
- end loop;
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Act,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (T, Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint
- (Loc, Constraints)));
-
- Insert_Before (N, Decl);
- Analyze (Decl);
- return Act;
- end Build_Default_Subtype;
-
-----------------
-- Count_Tasks --
-----------------
return;
end if;
- -- In the normal case, enter identifier at the start to catch
- -- premature usage in the initialization expression.
+ -- In the normal case, enter identifier at the start to catch premature
+ -- usage in the initialization expression.
else
Generate_Definition (Id);
-- out some static checks
if Ada_Version >= Ada_05
- and then (Null_Exclusion_Present (N)
- or else Can_Never_Be_Null (T))
+ and then Can_Never_Be_Null (T)
then
- Set_Can_Never_Be_Null (Id);
- Null_Exclusion_Static_Checks (N);
+ -- 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 Present (Expression (N))
+ and then Nkind (Expression (N)) = N_Aggregate
+ then
+ null;
+
+ else
+ 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;
end if;
Set_Is_Pure (Id, Is_Pure (Current_Scope));
if Constant_Present (N)
and then No (E)
then
- if not Is_Package (Current_Scope) then
+ if not Is_Package_Or_Generic_Package (Current_Scope) then
Error_Msg_N
("invalid context for deferred constant declaration ('R'M 7.4)",
N);
-- In case of errors detected in the analysis of the expression,
-- decorate it with the expected type to avoid cascade errors
- if not Present (Etype (E)) then
+ if No (Etype (E)) then
Set_Etype (E, T);
end if;
Set_Has_Completion (Id);
end if;
+ Set_Etype (Id, T); -- may be overridden later on
+ Resolve (E, T);
+
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
-
- Set_Etype (Id, T); -- may be overridden later on
- Resolve (E, T);
Check_Unset_Reference (E);
- if Compile_Time_Known_Value (E) then
- Set_Current_Value (Id, E);
+ -- If this is a variable, then set current value
+
+ if not Constant_Present (N) then
+ if Compile_Time_Known_Value (E) then
+ Set_Current_Value (Id, E);
+ end if;
end if;
-- Check incorrect use of dynamically tagged expressions. Note
Apply_Length_Check (E, T);
end if;
+ -- If the type is limited unconstrained with defaulted discriminants
+ -- and there is no expression, then the object is constrained by the
+ -- defaults, so it is worthwhile building the corresponding subtype.
+
elsif (Is_Limited_Record (T)
or else Is_Concurrent_Type (T))
and then not Is_Constrained (T)
and then Has_Discriminants (T)
then
- Act_T := Build_Default_Subtype;
+ if No (E) then
+ Act_T := Build_Default_Subtype (T, N);
+ else
+ -- Ada 2005: a limited object may be initialized by means of an
+ -- aggregate. If the type has default discriminants it has an
+ -- unconstrained nominal type, Its actual subtype will be obtained
+ -- from the aggregate, and not from the default discriminants.
+
+ Act_T := Etype (E);
+ end if;
+
Rewrite (Object_Definition (N), New_Occurrence_Of (Act_T, Loc));
- elsif not Is_Constrained (T)
- and then Has_Discriminants (T)
- and then Constant_Present (N)
+ elsif Present (Underlying_Type (T))
+ and then not Is_Constrained (Underlying_Type (T))
+ and then Has_Discriminants (Underlying_Type (T))
and then Nkind (E) = N_Function_Call
+ and then Constant_Present (N)
then
-- The back-end has problems with constants of a discriminated type
-- with defaults, if the initial value is a function call. We
if Aliased_Present (N) then
Set_Is_Aliased (Id);
+ -- If the object is aliased and the type is unconstrained with
+ -- defaulted discriminants and there is no expression, then the
+ -- object is constrained by the defaults, so it is worthwhile
+ -- building the corresponding subtype.
+
+ -- Ada 2005 (AI-363): If the aliased object is discriminated and
+ -- unconstrained, then only establish an actual subtype if the
+ -- nominal subtype is indefinite. In definite cases the object is
+ -- unconstrained in Ada 2005.
+
if No (E)
and then Is_Record_Type (T)
and then not Is_Constrained (T)
and then Has_Discriminants (T)
+ and then (Ada_Version < Ada_05 or else Is_Indefinite_Subtype (T))
then
- Set_Actual_Subtype (Id, Build_Default_Subtype);
+ Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
end if;
end if;
Validate_Controlled_Object (Id);
end if;
- -- Generate a warning when an initialization causes an obvious
- -- ABE violation. If the init expression is a simple aggregate
- -- there shouldn't be any initialize/adjust call generated. This
- -- will be true as soon as aggregates are built in place when
- -- possible. ??? at the moment we do not generate warnings for
- -- temporaries created for those aggregates although a
- -- Program_Error might be generated if compiled with -gnato
+ -- Generate a warning when an initialization causes an obvious ABE
+ -- violation. If the init expression is a simple aggregate there
+ -- shouldn't be any initialize/adjust call generated. This will be
+ -- true as soon as aggregates are built in place when possible.
+
+ -- ??? at the moment we do not generate warnings for temporaries
+ -- created for those aggregates although Program_Error might be
+ -- generated if compiled with -gnato.
if Is_Controlled (Etype (Id))
and then Comes_From_Source (Id)
Implicit_Call : Entity_Id;
pragma Warnings (Off, Implicit_Call);
- -- What is this about, it is never referenced ???
+ -- ??? what is this for (never referenced!)
function Is_Aggr (N : Node_Id) return Boolean;
-- Check that N is an aggregate
end Is_Aggr;
begin
- -- If no underlying type, we already are in an error situation
- -- don't try to add a warning since we do not have access
+ -- If no underlying type, we already are in an error situation.
+ -- Do not try to add a warning since we do not have access to
-- prim-op list.
if No (Underlying_Type (BT)) then
elsif Is_Generic_Type (BT) then
Implicit_Call := Empty;
- -- if the init expression is not an aggregate, an adjust
- -- call will be generated
+ -- If the init expression is not an aggregate, an adjust call
+ -- will be generated
elsif Present (E) and then not Is_Aggr (E) then
Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
- -- if no init expression and we are not in the deferred
+ -- If no init expression and we are not in the deferred
-- constant case, an Initialize call will be generated
elsif No (E) and then not Constant_Present (N) then
and then Nkind (E) = N_Explicit_Dereference
and then Nkind (Original_Node (E)) = N_Function_Call
and then not Is_Library_Level_Entity (Id)
- and then not Is_Constrained (T)
+ and then not Is_Constrained (Underlying_Type (T))
and then not Is_Aliased (Id)
and then not Is_Class_Wide_Type (T)
and then not Is_Controlled (T)
Set_Renamed_Object (Id, E);
- -- Force generation of debugging information for the constant
- -- and for the renamed function call.
+ -- Force generation of debugging information for the constant and for
+ -- the renamed function call.
Set_Needs_Debug_Info (Id);
Set_Needs_Debug_Info (Entity (Prefix (E)));
end if;
Check_Eliminated (Id);
+
+ -- Deal with setting In_Private_Part flag if in private part
+
+ if Ekind (Scope (Id)) = E_Package
+ and then In_Private_Part (Scope (Id))
+ then
+ Set_In_Private_Part (Id);
+ end if;
end Analyze_Object_Declaration;
---------------------------
Parent_Base : Entity_Id;
begin
- -- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
- -- interfaces
+ -- Ada 2005 (AI-251): Decorate all names in list of ancestor interfaces
if Is_Non_Empty_List (Interface_List (N)) then
declare
- I : Node_Id := First (Interface_List (N));
- T : Entity_Id;
+ Intf : Node_Id;
+ T : Entity_Id;
+
begin
- while Present (I) loop
- T := Find_Type_Of_Subtype_Indic (I);
+ Intf := First (Interface_List (N));
+ while Present (Intf) loop
+ T := Find_Type_Of_Subtype_Indic (Intf);
if not Is_Interface (T) then
- Error_Msg_NE ("(Ada 2005) & must be an interface", I, T);
+ Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T);
end if;
- Next (I);
+ Next (Intf);
end loop;
end;
end if;
return;
end if;
- if (not Is_Package (Current_Scope)
+ if (not Is_Package_Or_Generic_Package (Current_Scope)
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
or else In_Private_Part (Current_Scope)
end if;
Build_Derived_Record_Type (N, Parent_Type, T);
- end Analyze_Private_Extension_Declaration;
- ---------------------------------
- -- Analyze_Subtype_Declaration --
- ---------------------------------
+ -- Ada 2005 (AI-443): Synchronized private extension or a rewritten
+ -- synchronized formal derived type.
- procedure Analyze_Subtype_Declaration (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- T : Entity_Id;
- R_Checks : Check_Result;
+ if Ada_Version >= Ada_05
+ and then Synchronized_Present (N)
+ then
+ Set_Is_Limited_Record (T);
- begin
- Generate_Definition (Id);
- Set_Is_Pure (Id, Is_Pure (Current_Scope));
- Init_Size_Align (Id);
+ -- Formal derived type case
- -- The following guard condition on Enter_Name is to handle cases
- -- where the defining identifier has already been entered into the
- -- scope but the declaration as a whole needs to be analyzed.
+ if Is_Generic_Type (T) then
+
+ -- The parent must be a tagged limited type or a synchronized
+ -- interface.
+
+ if (not Is_Tagged_Type (Parent_Type)
+ or else not Is_Limited_Type (Parent_Type))
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Synchronized_Interface (Parent_Type))
+ then
+ Error_Msg_NE ("parent type of & must be tagged limited " &
+ "or synchronized", N, T);
+ end if;
+
+ -- The progenitors (if any) must be limited or synchronized
+ -- interfaces.
+
+ if Present (Abstract_Interfaces (T)) then
+ declare
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Iface_Elmt := First_Elmt (Abstract_Interfaces (T));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if not Is_Limited_Interface (Iface)
+ and then not Is_Synchronized_Interface (Iface)
+ then
+ Error_Msg_NE ("progenitor & must be limited " &
+ "or synchronized", N, Iface);
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
+ -- Regular derived extension, the parent must be a limited or
+ -- synchronized interface.
+
+ else
+ if not Is_Interface (Parent_Type)
+ or else (not Is_Limited_Interface (Parent_Type)
+ and then
+ not Is_Synchronized_Interface (Parent_Type))
+ then
+ Error_Msg_NE
+ ("parent type of & must be limited interface", N, T);
+ end if;
+ end if;
+
+ elsif Limited_Present (N) then
+ Set_Is_Limited_Record (T);
+
+ if not Is_Limited_Type (Parent_Type)
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Limited_Interface (Parent_Type))
+ then
+ Error_Msg_NE ("parent type& of limited extension must be limited",
+ N, Parent_Type);
+ end if;
+ end if;
+ end Analyze_Private_Extension_Declaration;
+
+ ---------------------------------
+ -- Analyze_Subtype_Declaration --
+ ---------------------------------
+
+ procedure Analyze_Subtype_Declaration
+ (N : Node_Id;
+ Skip : Boolean := False)
+ is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ T : Entity_Id;
+ R_Checks : Check_Result;
+
+ begin
+ Generate_Definition (Id);
+ Set_Is_Pure (Id, Is_Pure (Current_Scope));
+ Init_Size_Align (Id);
+
+ -- The following guard condition on Enter_Name is to handle cases where
+ -- the defining identifier has already been entered into the scope but
+ -- the declaration as a whole needs to be analyzed.
-- This case in particular happens for derived enumeration types. The
- -- derived enumeration type is processed as an inserted enumeration
- -- type declaration followed by a rewritten subtype declaration. The
- -- defining identifier, however, is entered into the name scope very
- -- early in the processing of the original type declaration and
- -- therefore needs to be avoided here, when the created subtype
- -- declaration is analyzed. (See Build_Derived_Types)
+ -- derived enumeration type is processed as an inserted enumeration type
+ -- declaration followed by a rewritten subtype declaration. The defining
+ -- identifier, however, is entered into the name scope very early in the
+ -- processing of the original type declaration and therefore needs to be
+ -- avoided here, when the created subtype declaration is analyzed. (See
+ -- Build_Derived_Types)
-- This also happens when the full view of a private type is derived
-- type with constraints. In this case the entity has been introduced
-- in the private declaration.
- if Present (Etype (Id))
- and then (Is_Private_Type (Etype (Id))
- or else Is_Task_Type (Etype (Id))
- or else Is_Rewrite_Substitution (N))
+ if Skip
+ or else (Present (Etype (Id))
+ and then (Is_Private_Type (Etype (Id))
+ or else Is_Task_Type (Etype (Id))
+ or else Is_Rewrite_Substitution (N)))
then
null;
Set_Is_Volatile (Id, Is_Volatile (T));
Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
Set_Is_Atomic (Id, Is_Atomic (T));
- Set_Is_Ada_2005 (Id, Is_Ada_2005 (T));
+ Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T));
-- In the case where there is no constraint given in the subtype
- -- indication, Process_Subtype just returns the Subtype_Mark,
- -- so its semantic attributes must be established here.
+ -- indication, Process_Subtype just returns the Subtype_Mark, so its
+ -- semantic attributes must be established here.
if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then
Set_Etype (Id, Base_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
end if;
- -- In general the attributes of the subtype of a private
- -- type are the attributes of the partial view of parent.
- -- However, the full view may be a discriminated type,
- -- and the subtype must share the discriminant constraint
- -- to generate correct calls to initialization procedures.
+ -- In general the attributes of the subtype of a private type
+ -- are the attributes of the partial view of parent. However,
+ -- the full view may be a discriminated type, and the subtype
+ -- must share the discriminant constraint to generate correct
+ -- calls to initialization procedures.
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Is_Access_Constant (T));
Set_Directly_Designated_Type
(Id, Designated_Type (T));
-
- -- Ada 2005 (AI-231): Propagate the null-excluding attribute
- -- and carry out some static checks
-
- if Null_Exclusion_Present (N)
- or else Can_Never_Be_Null (T)
- then
- Set_Can_Never_Be_Null (Id);
-
- if Null_Exclusion_Present (N)
- and then Can_Never_Be_Null (T)
- then
- Error_Msg_N
- ("(Ada 2005) null exclusion not allowed if parent "
- & "is already non-null", Subtype_Indication (N));
- end if;
- end if;
+ Set_Can_Never_Be_Null (Id, Can_Never_Be_Null (T));
-- A Pure library_item must not contain the declaration of a
-- named access type, except within a subprogram, generic
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
end if;
- -- If the subtype name denotes an incomplete type
- -- an error was already reported by Process_Subtype.
-
when E_Incomplete_Type =>
- Set_Etype (Id, Any_Type);
+ if Ada_Version >= Ada_05 then
+ Set_Ekind (Id, E_Incomplete_Subtype);
+
+ -- Ada 2005 (AI-412): Decorate an incomplete subtype
+ -- of an incomplete type visible through a limited
+ -- with clause.
+
+ if From_With_Type (T)
+ and then Present (Non_Limited_View (T))
+ then
+ Set_From_With_Type (Id);
+ Set_Non_Limited_View (Id, Non_Limited_View (T));
+
+ -- Ada 2005 (AI-412): Add the regular incomplete subtype
+ -- to the private dependents of the original incomplete
+ -- type for future transformation.
+
+ else
+ Append_Elmt (Id, Private_Dependents (T));
+ end if;
+
+ -- If the subtype name denotes an incomplete type an error
+ -- was already reported by Process_Subtype.
+
+ else
+ Set_Etype (Id, Any_Type);
+ end if;
when others =>
raise Program_Error;
or else
In_Package_Body (Current_Scope));
+ procedure Check_Ops_From_Incomplete_Type;
+ -- If there is a tagged incomplete partial view of the type, transfer
+ -- its operations to the full view, and indicate that the type of the
+ -- controlling parameter (s) is this full view.
+
+ ------------------------------------
+ -- 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)
+ then
+ Elmt := First_Elmt (Primitive_Operations (Prev));
+ while Present (Elmt) loop
+ Op := Node (Elmt);
+ Prepend_Elmt (Op, Primitive_Operations (T));
+
+ 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_Type_Declaration
+
begin
Prev := Find_Type_Name (N);
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).
+ -- 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);
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 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);
-- 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.
Nb_Index := 1;
while Present (Index) loop
Analyze (Index);
+
+ -- Add a subtype declaration for each index of private array type
+ -- declaration whose etype is also private. For example:
+
+ -- package Pkg is
+ -- type Index is private;
+ -- private
+ -- type Table is array (Index) of ...
+ -- end;
+
+ -- This is currently required by the expander to generate the
+ -- internally generated equality subprogram of records with variant
+ -- parts in which the etype of some component is such private type.
+
+ if Ekind (Current_Scope) = E_Package
+ and then In_Private_Part (Current_Scope)
+ and then Has_Private_Declaration (Etype (Index))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (Def);
+ New_E : Entity_Id;
+ Decl : Entity_Id;
+
+ begin
+ New_E :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+ Set_Is_Internal (New_E);
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => New_E,
+ Subtype_Indication =>
+ New_Occurrence_Of (Etype (Index), Loc));
+
+ Insert_Before (Parent (Def), Decl);
+ Analyze (Decl);
+ Set_Etype (Index, New_E);
+
+ -- If the index is a range the Entity attribute is not
+ -- available. Example:
+
+ -- package Pkg is
+ -- type T is private;
+ -- private
+ -- type T is new Natural;
+ -- Table : array (T(1) .. T(10)) of Boolean;
+ -- end Pkg;
+
+ if Nkind (Index) /= N_Range then
+ Set_Entity (Index, New_E);
+ end if;
+ end;
+ end if;
+
Make_Index (Index, P, Related_Id, Nb_Index);
Next_Index (Index);
Nb_Index := Nb_Index + 1;
end loop;
+ -- Process subtype indication if one is present
+
if Present (Subtype_Indication (Component_Def)) then
- Element_Type := Process_Subtype (Subtype_Indication (Component_Def),
- P, Related_Id, 'C');
+ Element_Type :=
+ Process_Subtype
+ (Subtype_Indication (Component_Def), P, Related_Id, 'C');
-- Ada 2005 (AI-230): Access Definition case
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
- -- array to ensure that objects of this type are initialized.
+ -- array type to ensure that objects of this type are initialized.
if Ada_Version >= Ada_05
- and then (Null_Exclusion_Present (Component_Definition (Def))
- or else Can_Never_Be_Null (Element_Type))
+ and then Can_Never_Be_Null (Element_Type)
then
Set_Can_Never_Be_Null (T);
if Null_Exclusion_Present (Component_Definition (Def))
- and then Can_Never_Be_Null (Element_Type)
+
+ -- No need to check itypes because in their case this check
+ -- was done at their point of creation
+
+ and then not Is_Itype (Element_Type)
then
Error_Msg_N
- ("(Ada 2005) already a null-excluding type",
+ ("null-exclusion cannot be applied to a null excluding type",
Subtype_Indication (Component_Definition (Def)));
end if;
end if;
Acc : Node_Id;
Comp : Node_Id;
Decl : Node_Id;
- P : Node_Id := Parent (N);
+ P : Node_Id;
begin
Set_Is_Internal (Anon);
-- Insert the new declaration in the nearest enclosing scope
+ P := Parent (N);
while Present (P) and then not Has_Declarations (P) loop
P := Parent (P);
end loop;
end if;
-- Replace the anonymous type with an occurrence of the new declaration.
- -- In all cases the rewriten node does not have the null-exclusion
+ -- In all cases the rewritten node does not have the null-exclusion
-- attribute because (if present) it was already inherited by the
-- anonymous entity (Anon). Thus, in case of components we do not
-- inherit this attribute.
end if;
end if;
- -- If the parent type is not a derived type itself, and is
- -- declared in a closed scope (e.g., a subprogram), then we
- -- need to explicitly introduce the new type's concatenation
- -- operator since Derive_Subprograms will not inherit the
- -- parent's operator. If the parent type is unconstrained, the
- -- operator is of the unconstrained base type.
+ -- If parent type is not a derived type itself, and is declared in
+ -- closed scope (e.g. a subprogram), then we must explicitly introduce
+ -- the new type's concatenation operator since Derive_Subprograms
+ -- will not inherit the parent's operator. If the parent type is
+ -- unconstrained, the operator is of the unconstrained base type.
if Number_Dimensions (Parent_Type) = 1
and then not Is_Limited_Type (Parent_Type)
and then not Is_Derived_Type (Parent_Type)
- and then not Is_Package (Scope (Base_Type (Parent_Type)))
+ and then not Is_Package_Or_Generic_Package
+ (Scope (Base_Type (Parent_Type)))
then
if not Is_Constrained (Parent_Type)
and then Is_Constrained (Derived_Type)
Make_Subtype_Declaration (Loc,
Defining_Identifier => Anon,
Subtype_Indication =>
- New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
+ Subtype_Indication (Type_Definition (N)));
Insert_Before (N, Decl);
+ Analyze (Decl);
+
Rewrite (Subtype_Indication (Type_Definition (N)),
New_Occurrence_Of (Anon, Loc));
- Analyze (Decl);
Set_Analyzed (Derived_Type, False);
Analyze (N);
return;
elsif Present (Discriminant_Specifications (N)) then
- -- Verify that new discriminants are used to constrain
- -- the old ones.
+ -- Verify that new discriminants are used to constrain old ones
- Old_Disc := First_Discriminant (Parent_Type);
- New_Disc := First_Discriminant (Derived_Type);
- Disc_Spec := First (Discriminant_Specifications (N));
D_Constraint :=
First
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
+ Old_Disc := First_Discriminant (Parent_Type);
+ New_Disc := First_Discriminant (Derived_Type);
+ Disc_Spec := First (Discriminant_Specifications (N));
while Present (Old_Disc) and then Present (Disc_Spec) loop
-
if Nkind (Discriminant_Type (Disc_Spec)) /=
N_Access_Definition
then
Literal := First_Literal (Parent_Type);
Literals_List := New_List;
-
while Present (Literal)
and then Ekind (Literal) = E_Enumeration_Literal
loop
-- overridden by an explicit representation clause. Indicate
-- that there is no explicit representation given yet. These
-- derived literals are implicit operations of the new type,
- -- and can be overriden by explicit ones.
+ -- and can be overridden by explicit ones.
if Nkind (Literal) = N_Defining_Character_Literal then
New_Lit :=
-- affect anything, but it is still baffling that we cannot use the
-- same mechanism for all derived numeric types.
+ -- There is a further complication: actually *some* representation
+ -- clauses can affect the implicit base type. Namely, attribute
+ -- definition clauses for stream-oriented attributes need to set the
+ -- corresponding TSS entries on the base type, and this normally cannot
+ -- be done after the base type is frozen, so the circuitry in
+ -- Sem_Ch13.New_Stream_Subprogram must account for this possibility and
+ -- not use Set_TSS in this case.
+
if Is_Fixed_Point_Type (Parent_Type) then
Conditional_Delay (Implicit_Base, Parent_Type);
else
Full_Decl := New_Copy_Tree (N);
Full_Der := New_Copy (Derived_Type);
Set_Comes_From_Source (Full_Decl, False);
+ Set_Comes_From_Source (Full_Der, False);
Insert_After (N, Full_Decl);
-- view, the completion does not derive them anew.
if not Is_Tagged_Type (Parent_Type) then
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, False);
+
+ -- If the parent is itself derived from another private type,
+ -- installing the private declarations has not affected its
+ -- privacy status, so use its own full view explicitly.
+
+ if Is_Private_Type (Parent_Type) then
+ Build_Derived_Record_Type
+ (Full_Decl, Full_View (Parent_Type), Full_Der, False);
+ else
+ Build_Derived_Record_Type
+ (Full_Decl, Parent_Type, Full_Der, False);
+ end if;
else
-- If full view of parent is tagged, the completion
-- quite subtle.
-- type Derived_Type_Name [KNOWN_DISCRIMINANT_PART] is new
- -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
+ -- [abstract] Parent_Type_Name [CONSTRAINT] [RECORD_EXTENSION_PART]
-- If parent type has discriminants, then the discriminants that are
-- declared in the derived type are [3.4 (11)]:
-- o If the parent type is not a tagged type, then each discriminant of
-- the derived type shall be used in the constraint defining a parent
- -- subtype [Implementation note: this ensures that the new discriminant
- -- can share storage with an existing discriminant.].
+ -- subtype. [Implementation note: This ensures that the new discriminant
+ -- can share storage with an existing discriminant.]
-- For the derived type each discriminant of the parent type is either
-- inherited, constrained to equal some new discriminant of the derived
-- 4. DISCRIMINANTS IN DERIVED TAGGED RECORD TYPES
- -- Type derivation for tagged types is fairly straightforward. if no
+ -- Type derivation for tagged types is fairly straightforward. If no
-- discriminants are specified by the derived type, these are inherited
-- from the parent. No explicit stored discriminants are ever necessary.
-- The only manipulation that is done to the tree is that of adding a
(Nkind (N) = N_Private_Extension_Declaration);
Constraint_Present : Boolean;
- Has_Interfaces : Boolean := False;
Inherit_Discrims : Boolean := False;
- Last_Inherited_Prim_Op : Elmt_Id;
- Tagged_Partial_View : Entity_Id;
Save_Etype : Entity_Id;
Save_Discr_Constr : Elist_Id;
Save_Next_Entity : Entity_Id;
begin
C1 := First_Elmt (New_Discrs);
C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
-
while Present (C1) and then Present (C2) loop
if not
Fully_Conformant_Expressions (Node (C1), Node (C2))
"constraint not conformant to previous declaration",
Node (C1));
end if;
+
Next_Elmt (C1);
Next_Elmt (C2);
end loop;
if Is_Tagged then
-- The parent type is frozen for non-private extensions (RM 13.14(7))
+ -- The declaration of a specific descendant of an interface type
+ -- freezes the interface type (RM 13.14).
- if not Private_Extension then
+ if not Private_Extension
+ or else Is_Interface (Parent_Base)
+ then
Freeze_Before (N, Parent_Type);
end if;
if Ada_Version >= Ada_05 then
if Present (Enclosing_Generic_Body (Derived_Type)) then
declare
- Ancestor_Type : Entity_Id := Parent_Type;
+ Ancestor_Type : Entity_Id;
begin
-- Check to see if any ancestor of the derived type is a
-- formal type.
+ Ancestor_Type := Parent_Type;
while not Is_Generic_Type (Ancestor_Type)
and then Etype (Ancestor_Type) /= Ancestor_Type
loop
begin
if Is_Non_Empty_List (Interface_List (Type_Def)) then
Iface := First (Interface_List (Type_Def));
-
while Present (Iface) loop
Freeze_Before (N, Etype (Iface));
Next (Iface);
-- STEP 1c: Initialize some flags for the Derived_Type
-- The following flags must be initialized here so that
- -- Process_Discriminants can check that discriminants of tagged types
- -- do not have a default initial value and that access discriminants
- -- are only specified for limited records. For completeness, these
- -- flags are also initialized along with all the other flags below.
+ -- Process_Discriminants can check that discriminants of tagged types do
+ -- not have a default initial value and that access discriminants are
+ -- only specified for limited records. For completeness, these flags are
+ -- also initialized along with all the other flags below.
+
+ -- AI-419: Limitedness is not inherited from an interface parent, so to
+ -- be limited in that case the type must be explicitly declared as
+ -- limited.
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
- Set_Is_Limited_Record (Derived_Type, Is_Limited_Record (Parent_Type));
+ Set_Is_Limited_Record (Derived_Type,
+ Limited_Present (Type_Def)
+ or else (Is_Limited_Record (Parent_Type)
+ and then not Is_Interface (Parent_Type)));
-- STEP 2a: process discriminants of derived type if any
Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop
if not Is_Tagged
- and then not Present (Corresponding_Discriminant (Discrim))
+ and then No (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("new discriminants must constrain old ones", Discrim);
if not
Fully_Conformant_Expressions (Node (C1), Node (C2))
then
- Error_Msg_N (
- "not conformant with previous declaration",
- Node (C1));
+ Error_Msg_N
+ ("not conformant with previous declaration",
+ Node (C1));
end if;
Next_Elmt (C1);
Set_Is_Limited_Composite
(Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Limited_Record
- (Derived_Type, Is_Limited_Record (Parent_Type));
+ (Derived_Type,
+ Is_Limited_Record (Parent_Type)
+ and then not Is_Interface (Parent_Type));
Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type));
(Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
end if;
- -- Ada 2005 (AI-251): Look for the partial view of tagged types
- -- declared in the private part. This will be used 1) to check that
- -- the set of interfaces in both views is equal, and 2) to complete
- -- the derivation of subprograms covering interfaces.
-
- Tagged_Partial_View := Empty;
-
- if Has_Private_Declaration (Derived_Type) then
- Tagged_Partial_View := Next_Entity (Derived_Type);
- loop
- exit when Has_Private_Declaration (Tagged_Partial_View)
- and then Full_View (Tagged_Partial_View) = Derived_Type;
-
- Next_Entity (Tagged_Partial_View);
- end loop;
- end if;
-
- -- Ada 2005 (AI-251): Collect the whole list of implemented
- -- interfaces.
+ -- Ada 2005 (AI-251): Collect the list of progenitors that are not
+ -- already in the parents.
if Ada_Version >= Ada_05 then
- Set_Abstract_Interfaces (Derived_Type, New_Elmt_List);
-
- if Nkind (N) = N_Private_Extension_Declaration then
- Collect_Interfaces (N, Derived_Type);
- else
- Collect_Interfaces (Type_Definition (N), Derived_Type);
- end if;
-
- -- Check that the full view and the partial view agree
- -- in the set of implemented interfaces
-
- if Has_Private_Declaration (Derived_Type)
- and then Present (Abstract_Interfaces (Derived_Type))
- and then not Is_Empty_Elmt_List
- (Abstract_Interfaces (Derived_Type))
- then
- declare
- N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
- N_Full : constant Node_Id := Parent (Derived_Type);
-
- Iface_Partial : Entity_Id;
- Iface_Full : Entity_Id;
- Num_Ifaces_Partial : Natural := 0;
- Num_Ifaces_Full : Natural := 0;
- Same_Interfaces : Boolean := True;
-
- begin
- if Nkind (N_Partial) /= N_Private_Extension_Declaration then
- Error_Msg_N
- ("(Ada 2005) interfaces only allowed in private"
- & " extension declarations", N_Partial);
- end if;
-
- -- Count the interfaces implemented by the partial view
-
- if Nkind (N_Partial) = N_Private_Extension_Declaration
- and then not Is_Empty_List (Interface_List (N_Partial))
- then
- Iface_Partial := First (Interface_List (N_Partial));
-
- while Present (Iface_Partial) loop
- Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
- Next (Iface_Partial);
- end loop;
- end if;
-
- -- Take into account the case in which the partial
- -- view is a directly derived from an interface
-
- if Is_Interface (Etype
- (Defining_Identifier (N_Partial)))
- then
- Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
- end if;
-
- -- Count the interfaces implemented by the full view
-
- if not Is_Empty_List (Interface_List
- (Type_Definition (N_Full)))
- then
- Iface_Full := First (Interface_List
- (Type_Definition (N_Full)));
-
- while Present (Iface_Full) loop
- Num_Ifaces_Full := Num_Ifaces_Full + 1;
- Next (Iface_Full);
- end loop;
- end if;
-
- -- Take into account the case in which the full
- -- view is a directly derived from an interface
-
- if Is_Interface (Etype
- (Defining_Identifier (N_Full)))
- then
- Num_Ifaces_Full := Num_Ifaces_Full + 1;
- end if;
-
- if Num_Ifaces_Full > 0
- and then Num_Ifaces_Full = Num_Ifaces_Partial
- then
-
- -- Check that the full-view and the private-view have
- -- the same list of interfaces
-
- Iface_Full := First (Interface_List
- (Type_Definition (N_Full)));
-
- while Present (Iface_Full) loop
- Iface_Partial := First (Interface_List (N_Partial));
-
- while Present (Iface_Partial)
- and then Etype (Iface_Partial) /= Etype (Iface_Full)
- loop
- Next (Iface_Partial);
- end loop;
-
- -- If not found we check if the partial view is a
- -- direct derivation of the interface.
-
- if not Present (Iface_Partial)
- and then
- Etype (Tagged_Partial_View) /= Etype (Iface_Full)
- then
- Same_Interfaces := False;
- exit;
- end if;
-
- Next (Iface_Full);
- end loop;
- end if;
-
- if Num_Ifaces_Partial /= Num_Ifaces_Full
- or else not Same_Interfaces
- then
- Error_Msg_N
- ("(Ada 2005) full declaration and private declaration"
- & " must have the same list of interfaces",
- Derived_Type);
- end if;
- end;
- end if;
+ declare
+ Ifaces_List : Elist_Id;
+ begin
+ Collect_Abstract_Interfaces
+ (T => Derived_Type,
+ Ifaces_List => Ifaces_List,
+ Exclude_Parent_Interfaces => True);
+ Set_Abstract_Interfaces (Derived_Type, Ifaces_List);
+ end;
end if;
else
Constrs := Discriminant_Constraint (Parent_Type);
end if;
- Assoc_List := Inherit_Components (N,
- Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
+ Assoc_List :=
+ Inherit_Components
+ (N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
-- STEP 5a: Copy the parent record declaration for untagged types
End_Scope;
- if Etype (Derived_Type) = Any_Type then
+ -- Nothing else to do if there is an error in the derivation.
+ -- An unusual case: the full view may be derived from a type in an
+ -- instance, when the partial view was used illegally as an actual
+ -- in that instance, leading to a circular definition.
+
+ if Etype (Derived_Type) = Any_Type
+ or else Etype (Parent_Type) = Derived_Type
+ then
return;
end if;
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
-
- -- Ada 2005 (AI-251): Check if this tagged type implements abstract
- -- interfaces
-
- Has_Interfaces := False;
-
- if Is_Tagged_Type (Derived_Type) then
- declare
- E : Entity_Id;
-
- begin
- E := Derived_Type;
- loop
- if Is_Interface (E)
- or else (Present (Abstract_Interfaces (E))
- and then
- not Is_Empty_Elmt_List (Abstract_Interfaces (E)))
- then
- Has_Interfaces := True;
- exit;
- end if;
-
- exit when Etype (E) = E
-
- -- Protect the frontend against wrong source
-
- or else Etype (E) = Derived_Type;
-
- E := Etype (E);
- end loop;
- end;
- end if;
-
- -- Ada 2005 (AI-251): Keep separate the management of tagged types
- -- implementing interfaces
-
- if Is_Tagged_Type (Derived_Type)
- and then Has_Interfaces
- then
- -- Complete the decoration of private tagged types
-
- if Present (Tagged_Partial_View) then
- Complete_Subprograms_Derivation
- (Partial_View => Tagged_Partial_View,
- Derived_Type => Derived_Type);
- end if;
-
- -- Ada 2005 (AI-251): Derive the interface subprograms of all the
- -- implemented interfaces and check if some of the subprograms
- -- inherited from the ancestor cover some interface subprogram.
-
- if not Present (Tagged_Partial_View) then
- declare
- Subp_Elmt : Elmt_Id := First_Elmt
- (Primitive_Operations
- (Derived_Type));
- Iface_Subp_Elmt : Elmt_Id;
- Subp : Entity_Id;
- Iface_Subp : Entity_Id;
- Is_Interface_Subp : Boolean;
-
- begin
- -- Ada 2005 (AI-251): Remember the entity corresponding to
- -- the last inherited primitive operation. This is required
- -- to check if some of the inherited subprograms covers some
- -- of the new interfaces.
-
- Last_Inherited_Prim_Op := No_Elmt;
-
- while Present (Subp_Elmt) loop
- Last_Inherited_Prim_Op := Subp_Elmt;
- Next_Elmt (Subp_Elmt);
- end loop;
-
- -- Ada 2005 (AI-251): Derive subprograms in abstract
- -- interfaces
-
- Derive_Interface_Subprograms (Derived_Type);
-
- -- Ada 2005 (AI-251): Check if some of the inherited
- -- subprograms cover some of the new interfaces.
-
- if Present (Last_Inherited_Prim_Op) then
- Iface_Subp_Elmt := Next_Elmt (Last_Inherited_Prim_Op);
- while Present (Iface_Subp_Elmt) loop
- Subp_Elmt := First_Elmt (Primitive_Operations
- (Derived_Type));
- while Subp_Elmt /= Last_Inherited_Prim_Op loop
- Subp := Node (Subp_Elmt);
- Iface_Subp := Node (Iface_Subp_Elmt);
-
- Is_Interface_Subp :=
- Present (Alias (Subp))
- and then Present (DTC_Entity (Alias (Subp)))
- and then Is_Interface (Scope
- (DTC_Entity
- (Alias (Subp))));
-
- if Chars (Subp) = Chars (Iface_Subp)
- and then not Is_Interface_Subp
- and then not Is_Abstract (Subp)
- and then Type_Conformant (Iface_Subp, Subp)
- then
- Check_Dispatching_Operation
- (Subp => Subp,
- Old_Subp => Iface_Subp);
-
- -- Traverse the list of aliased subprograms
-
- declare
- E : Entity_Id := Alias (Subp);
- begin
- while Present (Alias (E)) loop
- E := Alias (E);
- end loop;
- Set_Alias (Subp, E);
- end;
-
- Set_Has_Delayed_Freeze (Subp);
- exit;
- end if;
-
- Next_Elmt (Subp_Elmt);
- end loop;
-
- Next_Elmt (Iface_Subp_Elmt);
- end loop;
- end if;
- end;
- end if;
- end if;
end if;
-- If we have a private extension which defines a constrained derived
-- from a private extension declaration.
declare
- Rep : Node_Id := First_Rep_Item (Derived_Type);
+ Rep : Node_Id;
Found : Boolean := False;
begin
+ Rep := First_Rep_Item (Derived_Type);
while Present (Rep) loop
if Rep = First_Rep_Item (Parent_Type) then
Found := True;
then
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
- Set_Ekind (CR_Disc, E_In_Parameter);
- Set_Mechanism (CR_Disc, Default_Mechanism);
- Set_Etype (CR_Disc, Etype (Discrim));
- Set_CR_Discriminant (Discrim, CR_Disc);
+ Set_Ekind (CR_Disc, E_In_Parameter);
+ Set_Mechanism (CR_Disc, Default_Mechanism);
+ Set_Etype (CR_Disc, Etype (Discrim));
+ Set_Discriminal_Link (CR_Disc, Discrim);
+ Set_CR_Discriminant (Discrim, CR_Disc);
end if;
end Build_Discriminal;
Discr := First_Discriminant (T);
Constr := First (Constraints (C));
-
for D in Discr_Expr'Range loop
exit when Nkind (Constr) = N_Discriminant_Association;
-- to find the name of the corresponding discriminant in the
-- actual record type T and not the name of the discriminant in
-- the generic formal. Example:
- --
+
-- generic
-- type G (D : int) is private;
-- package P is
-- end package;
-- type Rec (X : int) is record ... end record;
-- package Q is new P (G => Rec);
- --
+
-- At the point of the instantiation, formal type G is Rec
-- and therefore when reanalyzing "subtype W is G (D => 1);"
-- which really looks like "subtype W is Rec (D => 1);" at
-- Determine if there are discriminant expressions in the constraint
for J in Discr_Expr'Range loop
- if Denotes_Discriminant (Discr_Expr (J), Check_Protected => True) then
+ if Denotes_Discriminant
+ (Discr_Expr (J), Check_Concurrent => True)
+ then
Discrim_Present := True;
end if;
end loop;
Discr := First_Discriminant (T);
for J in Discr_Expr'Range loop
if Discr_Expr (J) /= Error then
-
Append_Elmt (Discr_Expr (J), Elist);
-- If any of the discriminant constraints is given by a
Force_Evaluation (Discr_Expr (J));
end if;
- -- Check that the designated type of an access discriminant's
- -- expression is not a class-wide type unless the discriminant's
- -- designated type is also class-wide.
+ -- Check that the designated type of an access discriminant's
+ -- expression is not a class-wide type unless the discriminant's
+ -- designated type is also class-wide.
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
and then not Is_Class_Wide_Type
For_Access : Boolean := False)
is
Has_Discrs : constant Boolean := Has_Discriminants (T);
- Constrained : constant Boolean
- := (Has_Discrs
- and then not Is_Empty_Elmt_List (Elist)
- and then not Is_Class_Wide_Type (T))
- or else Is_Constrained (T);
+ Constrained : constant Boolean :=
+ (Has_Discrs
+ and then not Is_Empty_Elmt_List (Elist)
+ and then not Is_Class_Wide_Type (T))
+ or else Is_Constrained (T);
begin
if Ekind (T) = E_Record_Type then
Set_Ekind (Def_Id, E_Class_Wide_Subtype);
else
- -- Incomplete type. attach subtype to list of dependents, to be
+ -- Incomplete type. Attach subtype to list of dependents, to be
-- completed with full view of parent type, unless is it the
-- designated subtype of a record component within an init_proc.
-- This last case arises for a component of an access type whose
end if;
if Is_Tagged_Type (T) then
- Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+
+ -- Ada 2005 (AI-251): In case of concurrent types we inherit the
+ -- concurrent record type (which has the list of primitive
+ -- operations).
+
+ if Ada_Version >= Ada_05
+ and then Is_Concurrent_Type (T)
+ then
+ Set_Corresponding_Record_Type (Def_Id,
+ Corresponding_Record_Type (T));
+ else
+ Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+ end if;
+
Set_Is_Abstract (Def_Id, Is_Abstract (T));
end if;
Set_Cloned_Subtype (Def_Id, T);
end if;
end if;
-
end Build_Discriminated_Subtype;
------------------------
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
-
while Present (Disc) loop
if Chars (Disc) = Chars (Id)
and then Present (Corresponding_Discriminant (Disc))
-------------------------------
procedure Check_Abstract_Overriding (T : Entity_Id) is
- Op_List : Elist_Id;
- Elmt : Elmt_Id;
- Subp : Entity_Id;
- Type_Def : Node_Id;
+ Alias_Subp : Entity_Id;
+ Elmt : Elmt_Id;
+ Op_List : Elist_Id;
+ Subp : Entity_Id;
+ Type_Def : Node_Id;
begin
Op_List := Primitive_Operations (T);
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
Subp := Node (Elmt);
+ Alias_Subp := Alias (Subp);
+
+ -- Inherited subprograms are identified by the fact that they do not
+ -- come from source, and the associated source location is the
+ -- location of the first subtype of the derived type.
-- Special exception, do not complain about failure to override the
- -- stream routines _Input and _Output, since we always provide
+ -- stream routines _Input and _Output, as well as the primitive
+ -- operations used in dispatching selects since we always provide
-- automatic overridings for these subprograms.
- if Is_Abstract (Subp)
+ if (Is_Abstract (Subp)
+ or else (Has_Controlling_Result (Subp)
+ and then Present (Alias_Subp)
+ and then not Comes_From_Source (Subp)
+ and then Sloc (Subp) = Sloc (First_Subtype (T))))
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract (T)
+ and then Chars (Subp) /= Name_uDisp_Asynchronous_Select
+ and then Chars (Subp) /= Name_uDisp_Conditional_Select
+ and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
+ and then Chars (Subp) /= Name_uDisp_Timed_Select
+
+ -- Ada 2005 (AI-251): Do not consider hidden entities associated
+ -- with abstract interface types because the check will be done
+ -- with the aliased entity (otherwise we generate a duplicated
+ -- error message).
+
+ and then not Present (Abstract_Interface_Alias (Subp))
then
- if Present (Alias (Subp)) then
- -- Only perform the check for a derived subprogram when
- -- the type has an explicit record extension. This avoids
- -- incorrectly flagging abstract subprograms for the case
- -- of a type without an extension derived from a formal type
- -- with a tagged actual (can occur within a private part).
+ if Present (Alias_Subp) then
+
+ -- Only perform the check for a derived subprogram when the
+ -- type has an explicit record extension. This avoids
+ -- incorrectly flagging abstract subprograms for the case of a
+ -- type without an extension derived from a formal type with a
+ -- tagged actual (can occur within a private part).
+
+ -- Ada 2005 (AI-391): In the case of an inherited function with
+ -- a controlling result of the type, the rule does not apply if
+ -- the type is a null extension (unless the parent function
+ -- itself is abstract, in which case the function must still be
+ -- be overridden). The expander will generate an overriding
+ -- wrapper function calling the parent subprogram (see
+ -- Exp_Ch3.Make_Controlling_Wrapper_Functions).
Type_Def := Type_Definition (Parent (T));
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Type_Def))
+ and then
+ (Ada_Version < Ada_05
+ or else not Is_Null_Extension (T)
+ or else Ekind (Subp) = E_Procedure
+ or else not Has_Controlling_Result (Subp)
+ or else Is_Abstract (Alias_Subp)
+ or else Is_Access_Type (Etype (Subp)))
then
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
- -- Ada 2005 (AI-345): Protected or task type implementing
- -- abstract interfaces
+ -- Traverse the whole chain of aliased subprograms to
+ -- complete the error notification. This is especially
+ -- useful for traceability of the chain of entities when the
+ -- subprogram corresponds with an interface subprogram
+ -- (which might be defined in another package)
- elsif Is_Concurrent_Record_Type (T)
- and then Present (Abstract_Interfaces (T))
- then
- Error_Msg_NE
- ("interface subprogram & must be overridden",
- T, Subp);
+ if Present (Alias_Subp) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := Subp;
+ while Present (Alias (E)) loop
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE ("\& has been inherited #", T, Subp);
+ E := Alias (E);
+ end loop;
+
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE
+ ("\& has been inherited from subprogram #", T, Subp);
+ end;
+ end if;
+
+ -- Ada 2005 (AI-345): Protected or task type implementing
+ -- abstract interfaces.
+
+ elsif Is_Concurrent_Record_Type (T)
+ and then Present (Abstract_Interfaces (T))
+ then
+ -- The controlling formal of Subp must be of mode "out",
+ -- "in out" or an access-to-variable to be overridden.
+
+ if Ekind (First_Formal (Subp)) = E_In_Parameter then
+ Error_Msg_NE
+ ("first formal of & must be of mode `OUT`, `IN OUT` " &
+ "or access-to-variable", T, Subp);
+
+ if Is_Protected_Type
+ (Corresponding_Concurrent_Type (T))
+ then
+ Error_Msg_N
+ ("\to be overridden by protected procedure or " &
+ "entry (`R`M 9.4(11))", T);
+ else
+ Error_Msg_N
+ ("\to be overridden by task entry (`R`M 9.4(11))",
+ T);
+ end if;
+
+ -- Some other kind of overriding failure
+
+ else
+ Error_Msg_NE
+ ("interface subprogram & must be overridden",
+ T, Subp);
+ end if;
end if;
+
else
Error_Msg_NE
("abstract subprogram not allowed for type&",
Loc : Node_Id)
is
begin
- -- A discriminant_specification for an access discriminant
- -- shall appear only in the declaration for a task or protected
- -- type, or for a type with the reserved word 'limited' in
- -- its definition or in one of its ancestors. (RM 3.7(10))
+ -- A discriminant_specification for an access discriminant shall appear
+ -- only in the declaration for a task or protected type, or for a type
+ -- with the reserved word 'limited' in its definition or in one of its
+ -- ancestors. (RM 3.7(10))
if Nkind (Discriminant_Type (D)) = N_Access_Definition
and then not Is_Concurrent_Type (Current_Scope)
-- ??? Also need to check components of record extensions, but not
-- components of protected types (which are always limited).
- -- Ada 2005: AI-363 relaxes this rule, to allow heap objects
- -- of such types to be unconstrained. This is safe because it is
- -- illegal to create access subtypes to such types with explicit
- -- discriminant constraints.
+ -- Ada 2005: AI-363 relaxes this rule, to allow heap objects of such
+ -- types to be unconstrained. This is safe because it is illegal to
+ -- create access subtypes to such types with explicit discriminant
+ -- constraints.
if not Is_Limited_Type (T) then
if Ekind (T) = E_Record_Type then
if Is_Aliased (C)
and then Has_Discriminants (Etype (C))
and then not Is_Constrained (Etype (C))
- and then not In_Instance
+ and then not In_Instance_Body
and then Ada_Version < Ada_05
then
Error_Msg_N
if Has_Aliased_Components (T)
and then Has_Discriminants (Component_Type (T))
and then not Is_Constrained (Component_Type (T))
- and then not In_Instance
+ and then not In_Instance_Body
+ and then Ada_Version < Ada_05
then
Error_Msg_N
("aliased component type must be constrained ('R'M 3.6(11))",
begin
Var := First_Entity (Current_Scope);
-
while Present (Var) loop
exit when Etype (Var) = E
and then Comes_From_Source (Var);
Post_Error;
end if;
- elsif Is_Package (E) then
+ elsif Is_Package_Or_Generic_Package (E) then
if Unit_Requires_Body (E) then
if not Has_Completion (E)
and then Nkind (Parent (Unit_Declaration_Node (E))) /=
elsif Ekind (E) = E_Record_Type then
if Is_Tagged_Type (E) then
Check_Abstract_Overriding (E);
+ Check_Conventions (E);
end if;
Check_Aliased_Component_Types (E);
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is
begin
- if (Is_Limited_Type (T)
- or else Is_Limited_Composite (T))
+ if Is_Limited_Type (T)
and then not In_Instance
and then not In_Inlined_Body
then
- -- Ada 2005 (AI-287): Relax the strictness of the front-end in
- -- case of limited aggregates and extension aggregates.
+ if not OK_For_Limited_Init (Exp) then
+ -- In GNAT mode, this is just a warning, to allow it to be
+ -- evilly turned off. Otherwise it is a real error.
- if Ada_Version >= Ada_05
- and then (Nkind (Exp) = N_Aggregate
- or else Nkind (Exp) = N_Extension_Aggregate)
- then
- null;
- else
- Error_Msg_N
- ("cannot initialize entities of limited type", Exp);
- Explain_Limited_Type (T, Exp);
+ if GNAT_Mode then
+ Error_Msg_N
+ ("cannot initialize entities of limited type?", Exp);
+ else
+ Error_Msg_N
+ ("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
+ end if;
end if;
end if;
end Check_Initialization;
-- Check_Or_Process_Discriminants --
------------------------------------
- -- If an incomplete or private type declaration was already given for
- -- the type, the discriminants may have already been processed if they
- -- were present on the incomplete declaration. In this case a full
- -- conformance check is performed otherwise just process them.
+ -- If an incomplete or private type declaration was already given for the
+ -- type, the discriminants may have already been processed if they were
+ -- present on the incomplete declaration. In this case a full conformance
+ -- check is performed otherwise just process them.
procedure Check_Or_Process_Discriminants
(N : Node_Id;
-- Make the discriminants visible to component declarations
declare
- D : Entity_Id := First_Discriminant (T);
+ D : Entity_Id;
Prev : Entity_Id;
begin
+ D := First_Discriminant (T);
while Present (D) loop
Prev := Current_Entity (D);
Set_Current_Entity (D);
if Ada_Version < Ada_05 then
- -- This restriction gets applied to the full type here; it
- -- has already been applied earlier to the partial view
+ -- This restriction gets applied to the full type here. It
+ -- has already been applied earlier to the partial view.
Check_Access_Discriminant_Requires_Limited (Parent (D), N);
end if;
Resolve (Bound, Standard_Float);
end Check_Real_Bound;
- ------------------------
- -- Collect_Interfaces --
- ------------------------
-
- procedure Collect_Interfaces (N : Node_Id; Derived_Type : Entity_Id) is
- I : Node_Id;
-
- procedure Add_Interface (Iface : Entity_Id);
-
- procedure Add_Interface (Iface : Entity_Id) is
- Elmt : Elmt_Id := First_Elmt (Abstract_Interfaces (Derived_Type));
-
- begin
- while Present (Elmt) and then Node (Elmt) /= Iface loop
- Next_Elmt (Elmt);
- end loop;
-
- if not Present (Elmt) then
- Append_Elmt (Node => Iface,
- To => Abstract_Interfaces (Derived_Type));
- end if;
- end Add_Interface;
-
- begin
- pragma Assert (False
- or else Nkind (N) = N_Derived_Type_Definition
- or else Nkind (N) = N_Record_Definition
- or else Nkind (N) = N_Private_Extension_Declaration);
-
- -- Traverse the graph of ancestor interfaces
-
- if Is_Non_Empty_List (Interface_List (N)) then
- I := First (Interface_List (N));
-
- while Present (I) loop
-
- -- Protect against wrong usages. Example:
- -- type I is interface;
- -- type O is tagged null record;
- -- type Wrong is new I and O with null record;
-
- if Is_Interface (Etype (I)) then
-
- -- Do not add the interface when the derived type already
- -- implements this interface
-
- if not Interface_Present_In_Ancestor (Derived_Type,
- Etype (I))
- then
- Collect_Interfaces
- (Type_Definition (Parent (Etype (I))),
- Derived_Type);
- Add_Interface (Etype (I));
- end if;
- end if;
-
- Next (I);
- end loop;
- end if;
- end Collect_Interfaces;
-
------------------------------
-- Complete_Private_Subtype --
------------------------------
-- Next_Entity field of full to ensure that the calls to Copy_Node
-- do not corrupt the entity chain.
- -- Note that the type of the full view is the same entity as the
- -- type of the partial view. In this fashion, the subtype has
- -- access to the correct view of the parent.
+ -- Note that the type of the full view is the same entity as the type of
+ -- the partial view. In this fashion, the subtype has access to the
+ -- correct view of the parent.
Save_Next_Entity := Next_Entity (Full);
Save_Homonym := Homonym (Priv);
-- If the full base is itself derived from private, build a congruent
-- subtype of its underlying type, for use by the back end. For a
-- constrained record component, the declaration cannot be placed on
- -- the component list, but it must neverthess be built an analyzed, to
- -- supply enough information for gigi to compute the size of component.
+ -- the component list, but it must nevertheless be built an analyzed, to
+ -- supply enough information for Gigi to compute the size of component.
elsif Ekind (Full_Base) in Private_Kind
and then Is_Derived_Type (Full_Base)
end if;
end Complete_Private_Subtype;
- -------------------------------------
- -- Complete_Subprograms_Derivation --
- -------------------------------------
-
- procedure Complete_Subprograms_Derivation
- (Partial_View : Entity_Id;
- Derived_Type : Entity_Id)
- is
- Result : constant Elist_Id := New_Elmt_List;
- Elmt_P : Elmt_Id := No_Elmt;
- Elmt_D : Elmt_Id;
- Found : Boolean;
- Prim_Op : Entity_Id;
- E : Entity_Id;
-
- begin
- if Is_Tagged_Type (Partial_View) then
- Elmt_P := First_Elmt (Primitive_Operations (Partial_View));
- end if;
-
- -- Inherit primitives declared with the partial-view
-
- while Present (Elmt_P) loop
- Prim_Op := Node (Elmt_P);
- Found := False;
- Elmt_D := First_Elmt (Primitive_Operations (Derived_Type));
- while Present (Elmt_D) loop
- if Node (Elmt_D) = Prim_Op then
- Found := True;
- exit;
- end if;
-
- Next_Elmt (Elmt_D);
- end loop;
-
- if not Found then
- Append_Elmt (Prim_Op, Result);
-
- -- Search for entries associated with abstract interfaces that
- -- have been covered by this primitive
-
- Elmt_D := First_Elmt (Primitive_Operations (Derived_Type));
- while Present (Elmt_D) loop
- E := Node (Elmt_D);
-
- if Chars (E) = Chars (Prim_Op)
- and then Is_Abstract (E)
- and then Present (Alias (E))
- and then Present (DTC_Entity (Alias (E)))
- and then Is_Interface (Scope (DTC_Entity (Alias (E))))
- then
- Remove_Elmt (Primitive_Operations (Derived_Type), Elmt_D);
- end if;
-
- Next_Elmt (Elmt_D);
- end loop;
- end if;
-
- Next_Elmt (Elmt_P);
- end loop;
-
- -- Append the entities of the full-view to the list of primitives
- -- of derived_type
-
- Elmt_D := First_Elmt (Result);
- while Present (Elmt_D) loop
- Append_Elmt (Node (Elmt_D), Primitive_Operations (Derived_Type));
- Next_Elmt (Elmt_D);
- end loop;
- end Complete_Subprograms_Derivation;
-
----------------------------
-- Constant_Redeclaration --
----------------------------
Obj_Def : constant Node_Id := Object_Definition (N);
New_T : Entity_Id;
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id);
+ -- Determine whether the two object definitions describe the partial
+ -- and the full view of a constrained deferred constant. Generate
+ -- a subtype for the full view and verify that it statically matches
+ -- the subtype of the partial view.
+
procedure Check_Recursive_Declaration (Typ : Entity_Id);
- -- If deferred constant is an access type initialized with an
- -- allocator, check whether there is an illegal recursion in the
- -- definition, through a default value of some record subcomponent.
- -- This is normally detected when generating init procs, but requires
- -- this additional mechanism when expansion is disabled.
+ -- If deferred constant is an access type initialized with an allocator,
+ -- check whether there is an illegal recursion in the definition,
+ -- through a default value of some record subcomponent. This is normally
+ -- detected when generating init procs, but requires this additional
+ -- mechanism when expansion is disabled.
+
+ ----------------------------------------
+ -- Check_Possible_Deferred_Completion --
+ ----------------------------------------
+
+ procedure Check_Possible_Deferred_Completion
+ (Prev_Id : Entity_Id;
+ Prev_Obj_Def : Node_Id;
+ Curr_Obj_Def : Node_Id)
+ is
+ begin
+ if Nkind (Prev_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Prev_Obj_Def))
+ and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
+ and then Present (Constraint (Curr_Obj_Def))
+ then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('S'));
+ Decl : constant Node_Id :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier =>
+ Def_Id,
+ Subtype_Indication =>
+ Relocate_Node (Curr_Obj_Def));
+
+ begin
+ Insert_Before_And_Analyze (N, Decl);
+ Set_Etype (Id, Def_Id);
+
+ if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
+ Error_Msg_Sloc := Sloc (Prev_Id);
+ Error_Msg_N ("subtype does not statically match deferred " &
+ "declaration#", N);
+ end if;
+ end;
+ end if;
+ end Check_Possible_Deferred_Completion;
---------------------------------
-- Check_Recursive_Declaration --
-- If so, process the full constant declaration
else
+ -- RM 7.4 (6): If the subtype defined by the subtype_indication in
+ -- the deferred declaration is constrained, then the subtype defined
+ -- by the subtype_indication in the full declaration shall match it
+ -- statically.
+
+ Check_Possible_Deferred_Completion
+ (Prev_Id => Prev,
+ Prev_Obj_Def => Object_Definition (Parent (Prev)),
+ Curr_Obj_Def => Obj_Def);
+
Set_Full_View (Prev, Id);
Set_Is_Public (Id, Is_Public (Prev));
Set_Is_Internal (Id);
Conditional_Delay (Def_Id, T);
- -- AI-363 : Subtypes of general access types whose designated
- -- types have default discriminants are disallowed. In instances,
- -- the rule has to be checked against the actual, of which T is
- -- the subtype. In a generic body, the rule is checked assuming
- -- that the actual type has defaulted discriminants.
+ -- AI-363 : Subtypes of general access types whose designated types have
+ -- default discriminants are disallowed. In instances, the rule has to
+ -- be checked against the actual, of which T is the subtype. In a
+ -- generic body, the rule is checked assuming that the actual type has
+ -- defaulted discriminants.
if Ada_Version >= Ada_05 then
if Ekind (Base_Type (T)) = E_General_Access_Type
then
Error_Msg_N
("access subype of general access type not allowed", S);
- Error_Msg_N ("\ when discriminants have defaults", S);
+ Error_Msg_N ("\discriminants have defaults", S);
elsif Is_Access_Type (T)
and then Is_Generic_Type (Desig_Type)
then
Error_Msg_N ("access subtype not allowed in generic body", S);
Error_Msg_N
- ("\ wben designated type is a discriminated formal", S);
+ ("\designated type is a discriminated formal", S);
end if;
end if;
end Constrain_Access;
else
S := First (Constraints (C));
-
while Present (S) loop
Number_Of_Constraints := Number_Of_Constraints + 1;
Next (S);
Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
Set_Is_Limited_Composite (Def_Id, Is_Limited_Composite (T));
- -- Build a freeze node if parent still needs one. Also, make sure
- -- that the Depends_On_Private status is set (explanation ???)
+ -- Build a freeze node if parent still needs one. Also, make sure
+ -- that the Depends_On_Private status is set because the subtype
+ -- will need reprocessing at the time the base type does.
-- and also that a conditional delay is set.
Set_Depends_On_Private (Def_Id, Depends_On_Private (T));
---------------------
function Get_Discr_Value (Discrim : Entity_Id) return Node_Id is
- D : Entity_Id := First_Discriminant (Typ);
- E : Elmt_Id := First_Elmt (Constraints);
+ D : Entity_Id;
+ E : Elmt_Id;
G : Elmt_Id;
begin
-- case when constraining an inherited component whose constraint is
-- given by a discriminant of the parent.
+ D := First_Discriminant (Typ);
+ E := First_Elmt (Constraints);
+
while Present (D) loop
if D = Entity (Discrim)
+ or else D = CR_Discriminant (Entity (Discrim))
or else Corresponding_Discriminant (D) = Entity (Discrim)
then
return Node (E);
D := First_Discriminant (Etype (Typ));
E := First_Elmt (Constraints);
G := First_Elmt (Stored_Constraint (Typ));
-
while Present (D) loop
if D = Entity (Discrim) then
return Node (E);
or else (Is_Private_Type (Typ)
and then Chars (Discrim_Scope) = Chars (Typ))
+ -- Or we are constrained the corresponding record of a
+ -- synchronized type that completes a private declaration.
+
+ or else (Is_Concurrent_Record_Type (Typ)
+ and then
+ Corresponding_Concurrent_Type (Typ) = Discrim_Scope)
+
-- or we have a class-wide type, in which case make sure the
-- discriminant found belongs to the root type.
-- For concurrent types, the associated record value type carries the same
-- discriminants, so when we constrain a concurrent type, we must constrain
- -- the value type as well.
+ -- the corresponding record type as well.
procedure Constrain_Concurrent
(Def_Id : in out Entity_Id;
Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
- Conditional_Delay (T_Sub, Corr_Rec);
+ -- As elsewhere, we do not want to create a freeze node for this itype
+ -- if it is created for a constrained component of an enclosing record
+ -- because references to outer discriminants will appear out of scope.
+
+ if Ekind (Scope (Prot_Subt)) /= E_Record_Type then
+ Conditional_Delay (T_Sub, Corr_Rec);
+ else
+ Set_Is_Frozen (T_Sub);
+ end if;
if Has_Discriminants (Prot_Subt) then -- False only if errors.
Set_Discriminant_Constraint
T := Designated_Type (T);
end if;
+ -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
+ -- Avoid generating an error for access-to-incomplete subtypes.
+
+ if Ada_Version >= Ada_05
+ and then Ekind (T) = E_Incomplete_Type
+ and then Nkind (Parent (S)) = N_Subtype_Declaration
+ and then not Is_Itype (Def_Id)
+ then
+ -- A little sanity check, emit an error message if the type
+ -- has discriminants to begin with. Type T may be a regular
+ -- incomplete type or imported via a limited with clause.
+
+ if Has_Discriminants (T)
+ or else
+ (From_With_Type (T)
+ and then Present (Non_Limited_View (T))
+ and then Nkind (Parent (Non_Limited_View (T))) =
+ N_Full_Type_Declaration
+ and then Present (Discriminant_Specifications
+ (Parent (Non_Limited_View (T)))))
+ then
+ Error_Msg_N
+ ("(Ada 2005) incomplete subtype may not be constrained", C);
+ else
+ Error_Msg_N
+ ("invalid constraint: type has no discriminant", C);
+ end if;
+
+ Fixup_Bad_Constraint;
+ return;
+
-- Check that the type has visible discriminants. The type may be
-- a private type with unknown discriminants whose full view has
-- discriminants which are invisible.
- if not Has_Discriminants (T)
+ elsif not Has_Discriminants (T)
or else
(Has_Unknown_Discriminants (T)
and then Is_Private_Type (T))
New_Compon : constant Entity_Id := New_Copy (Old_Compon);
begin
- -- Set the parent so we have a proper link for freezing etc. This
- -- is not a real parent pointer, since of course our parent does
- -- not own up to us and reference us, we are an illegitimate
- -- child of the original parent!
+ if Ekind (Old_Compon) = E_Discriminant
+ and then Is_Completely_Hidden (Old_Compon)
+ then
+
+ -- This is a shadow discriminant created for a discriminant of
+ -- the parent type that is one of several renamed by the same
+ -- new discriminant. Give the shadow discriminant an internal
+ -- name that cannot conflict with that of visible components.
+
+ Set_Chars (New_Compon, New_Internal_Name ('C'));
+ end if;
+
+ -- Set the parent so we have a proper link for freezing etc. This is
+ -- not a real parent pointer, since of course our parent does not own
+ -- up to us and reference us, we are an illegitimate child of the
+ -- original parent!
Set_Parent (New_Compon, Parent (Old_Compon));
+ -- If the old component's Esize was already determined and is a
+ -- static value, then the new component simply inherits it. Otherwise
+ -- the old component's size may require run-time determination, but
+ -- the new component's size still might be statically determinable
+ -- (if, for example it has a static constraint). In that case we want
+ -- Layout_Type to recompute the component's size, so we reset its
+ -- size and positional fields.
+
+ if Frontend_Layout_On_Target
+ and then not Known_Static_Esize (Old_Compon)
+ then
+ Set_Esize (New_Compon, Uint_0);
+ Init_Normalized_First_Bit (New_Compon);
+ Init_Normalized_Position (New_Compon);
+ Init_Normalized_Position_Max (New_Compon);
+ end if;
+
-- We do not want this node marked as Comes_From_Source, since
- -- otherwise it would get first class status and a separate
- -- cross-reference line would be generated. Illegitimate
- -- children do not rate such recognition.
+ -- otherwise it would get first class status and a separate cross-
+ -- reference line would be generated. Illegitimate children do not
+ -- rate such recognition.
Set_Comes_From_Source (New_Compon, False);
- -- But it is a real entity, and a birth certificate must be
- -- properly registered by entering it into the entity list.
+ -- But it is a real entity, and a birth certificate must be properly
+ -- registered by entering it into the entity list.
Enter_Name (New_Compon);
+
return New_Compon;
end Create_Component;
Next_Elmt (Discr_Val);
end loop;
+ Set_Has_Static_Discriminants (Subt, Is_Static);
+
New_Scope (Subt);
-- Inherit the discriminants of the parent type
- Old_C := First_Discriminant (Typ);
- while Present (Old_C) loop
- New_C := Create_Component (Old_C);
- Set_Is_Public (New_C, Is_Public (Subt));
- Next_Discriminant (Old_C);
- end loop;
+ Add_Discriminants : declare
+ Num_Disc : Int;
+ Num_Gird : Int;
+
+ begin
+ Num_Disc := 0;
+ Old_C := First_Discriminant (Typ);
+
+ while Present (Old_C) loop
+ Num_Disc := Num_Disc + 1;
+ New_C := Create_Component (Old_C);
+ Set_Is_Public (New_C, Is_Public (Subt));
+ Next_Discriminant (Old_C);
+ end loop;
+
+ -- For an untagged derived subtype, the number of discriminants may
+ -- be smaller than the number of inherited discriminants, because
+ -- several of them may be renamed by a single new discriminant.
+ -- In this case, add the hidden discriminants back into the subtype,
+ -- because otherwise the size of the subtype is computed incorrectly
+ -- in GCC 4.1.
+
+ Num_Gird := 0;
+
+ if Is_Derived_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Old_C := First_Stored_Discriminant (Typ);
+
+ while Present (Old_C) loop
+ Num_Gird := Num_Gird + 1;
+ Next_Stored_Discriminant (Old_C);
+ end loop;
+ end if;
+
+ if Num_Gird > Num_Disc then
+
+ -- Find out multiple uses of new discriminants, and add hidden
+ -- components for the extra renamed discriminants. We recognize
+ -- multiple uses through the Corresponding_Discriminant of a
+ -- new discriminant: if it constrains several old discriminants,
+ -- this field points to the last one in the parent type. The
+ -- stored discriminants of the derived type have the same name
+ -- as those of the parent.
+
+ declare
+ Constr : Elmt_Id;
+ New_Discr : Entity_Id;
+ Old_Discr : Entity_Id;
+
+ begin
+ Constr := First_Elmt (Stored_Constraint (Typ));
+ Old_Discr := First_Stored_Discriminant (Typ);
+
+ while Present (Constr) loop
+ if Is_Entity_Name (Node (Constr))
+ and then Ekind (Entity (Node (Constr))) = E_Discriminant
+ then
+ New_Discr := Entity (Node (Constr));
+
+ if Chars (Corresponding_Discriminant (New_Discr))
+ /= Chars (Old_Discr)
+ then
+
+ -- The new discriminant has been used to rename
+ -- a subsequent old discriminant. Introduce a shadow
+ -- component for the current old discriminant.
+
+ New_C := Create_Component (Old_Discr);
+ Set_Original_Record_Component (New_C, Old_Discr);
+ end if;
+ end if;
+
+ Next_Elmt (Constr);
+ Next_Stored_Discriminant (Old_Discr);
+ end loop;
+ end;
+ end if;
+ end Add_Discriminants;
if Is_Static
and then Is_Variant_Record (Typ)
Create_All_Components;
else
- -- If the discriminants are not static, or if this is a multi-level
- -- type extension, we have to include all the components of the
- -- parent type.
+ -- If discriminants are not static, or if this is a multi-level type
+ -- extension, we have to include all components of the parent type.
Old_C := First_Component (Typ);
while Present (Old_C) loop
-- Check delta is power of 10, and determine scale value from it
declare
- Val : Ureal := Delta_Val;
+ Val : Ureal;
begin
Scale_Val := Uint_0;
+ Val := Delta_Val;
if Val < Ureal_1 then
while Val < Ureal_1 loop
Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
- ---------------------------------
- -- Derive_Interface_Subprogram --
- ---------------------------------
+ ----------------------------------
+ -- Derive_Interface_Subprograms --
+ ----------------------------------
- procedure Derive_Interface_Subprograms (Derived_Type : Entity_Id) is
+ procedure Derive_Interface_Subprograms
+ (Parent_Type : Entity_Id;
+ Tagged_Type : Entity_Id;
+ Ifaces_List : Elist_Id)
+ is
+ function Collect_Interface_Primitives
+ (Tagged_Type : Entity_Id) return Elist_Id;
+ -- Ada 2005 (AI-251): Collect the primitives of all the implemented
+ -- interfaces.
- procedure Do_Derivation (T : Entity_Id);
- -- This inner subprograms is used to climb to the ancestors.
- -- It is needed to add the derivations to the Derived_Type.
+ function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean;
+ -- Determine if Subp already in the list L
- procedure Do_Derivation (T : Entity_Id) is
- Etyp : constant Entity_Id := Etype (T);
- AI : Elmt_Id;
+ procedure Remove_Homonym (E : Entity_Id);
+ -- Removes E from the homonym chain
+
+ ----------------------------------
+ -- Collect_Interface_Primitives --
+ ----------------------------------
+
+ function Collect_Interface_Primitives
+ (Tagged_Type : Entity_Id) return Elist_Id
+ is
+ Op_List : constant Elist_Id := New_Elmt_List;
+ Elmt : Elmt_Id;
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Prim : Entity_Id;
begin
- if Etyp /= T
- and then Is_Interface (Etyp)
- then
- Do_Derivation (Etyp);
- end if;
+ pragma Assert (Is_Tagged_Type (Tagged_Type)
+ and then Has_Abstract_Interfaces (Tagged_Type));
- if Present (Abstract_Interfaces (T))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (T))
- then
- AI := First_Elmt (Abstract_Interfaces (T));
+ Collect_Abstract_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Elmt := First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
+
+ while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Append_Elmt (Prim, Op_List);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return Op_List;
+ end Collect_Interface_Primitives;
+
+ -------------
+ -- In_List --
+ -------------
- while Present (AI) loop
- Derive_Subprograms
- (Parent_Type => Node (AI),
- Derived_Type => Derived_Type,
- Is_Interface_Derivation => True);
+ function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is
+ Elmt : Elmt_Id;
+ begin
+ Elmt := First_Elmt (L);
+ while Present (Elmt) loop
+ if Node (Elmt) = Subp then
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ return False;
+ end In_List;
+
+ --------------------
+ -- Remove_Homonym --
+ --------------------
+
+ procedure Remove_Homonym (E : Entity_Id) is
+ Prev : Entity_Id := Empty;
+ H : Entity_Id;
- Next_Elmt (AI);
+ begin
+ if E = Current_Entity (E) then
+ Set_Current_Entity (Homonym (E));
+ else
+ H := Current_Entity (E);
+ while Present (H) and then H /= E loop
+ Prev := H;
+ H := Homonym (H);
end loop;
+
+ Set_Homonym (Prev, Homonym (E));
end if;
- end Do_Derivation;
+ end Remove_Homonym;
+
+ -- Local Variables
+
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Subp : Entity_Id;
+ New_Subp : Entity_Id := Empty;
+ Op_List : Elist_Id;
+ Parent_Base : Entity_Id;
+ Subp : Entity_Id;
+
+ -- Start of processing for Derive_Interface_Subprograms
begin
- Do_Derivation (Derived_Type);
+ if Ada_Version < Ada_05
+ or else not Is_Record_Type (Tagged_Type)
+ or else not Is_Tagged_Type (Tagged_Type)
+ or else not Has_Abstract_Interfaces (Tagged_Type)
+ then
+ return;
+ end if;
+
+ -- Add to the list of interface subprograms all the primitives inherited
+ -- from abstract interfaces that are not immediate ancestors and also
+ -- add their derivation to the list of interface primitives.
+
+ Op_List := Collect_Interface_Primitives (Tagged_Type);
+
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ Iface := Find_Dispatching_Type (Subp);
+
+ if not Is_Ancestor (Iface, Tagged_Type) then
+ Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface);
+ Append_Elmt (New_Subp, Ifaces_List);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Complete the derivation of the interface subprograms. Assignate to
+ -- each entity associated with abstract interfaces their aliased entity
+ -- and complete their decoration as hidden interface entities that will
+ -- be used later to build the secondary dispatch tables.
+
+ if not Is_Empty_Elmt_List (Ifaces_List) then
+ if Ekind (Parent_Type) = E_Record_Type_With_Private
+ and then Has_Discriminants (Parent_Type)
+ and then Present (Full_View (Parent_Type))
+ then
+ Parent_Base := Full_View (Parent_Type);
+ else
+ Parent_Base := Parent_Type;
+ end if;
+
+ Elmt := First_Elmt (Ifaces_List);
+ while Present (Elmt) loop
+ Iface_Subp := Node (Elmt);
+
+ -- Look for the first overriding entity in the homonym chain.
+ -- In this way if we are in the private part of a package spec
+ -- we get the last overriding subprogram.
+
+ E := Current_Entity_In_Scope (Iface_Subp);
+ while Present (E) loop
+ if Is_Dispatching_Operation (E)
+ and then Scope (E) = Scope (Iface_Subp)
+ and then Type_Conformant (E, Iface_Subp)
+ and then not In_List (Ifaces_List, E)
+ then
+ exit;
+ end if;
+
+ E := Homonym (E);
+ end loop;
- -- At this point the list of primitive operations of Derived_Type
- -- contains the entities corresponding to all the subprograms of all the
- -- implemented interfaces. If N interfaces have subprograms with the
- -- same profile we have N entities in this list because each one must be
- -- allocated in its corresponding virtual table.
+ -- Create an overriding entity if not found in the homonym chain
- -- Its alias attribute references its original interface subprogram.
- -- When overriden, the alias attribute is later saved in the
- -- Abstract_Interface_Alias attribute.
+ if not Present (E) then
+ Derive_Subprogram
+ (E, Alias (Iface_Subp), Tagged_Type, Parent_Base);
+
+ elsif not In_List (Primitive_Operations (Tagged_Type), E) then
+
+ -- Inherit the operation from the private view
+
+ Append_Elmt (E, Primitive_Operations (Tagged_Type));
+ end if;
+
+ -- Complete the decoration of the hidden interface entity
+
+ Set_Is_Hidden (Iface_Subp);
+ Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp));
+ Set_Alias (Iface_Subp, E);
+ Set_Is_Abstract (Iface_Subp, Is_Abstract (E));
+ Remove_Homonym (Iface_Subp);
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
end Derive_Interface_Subprograms;
-----------------------
Prev : Entity_Id;
begin
- -- The visible operation that is overriden is a homonym of the
+ -- If the parent is not a dispatching operation there is no
+ -- need to investigate overridings
+
+ if not Is_Dispatching_Operation (Parent_Subp) then
+ return False;
+ end if;
+
+ -- The visible operation that is overridden is a homonym of the
-- parent subprogram. We scan the homonym chain to find the one
-- whose alias is the subprogram we are deriving.
- Prev := Homonym (Parent_Subp);
+ Prev := Current_Entity (Parent_Subp);
while Present (Prev) loop
- if Is_Dispatching_Operation (Parent_Subp)
- and then Present (Prev)
- and then Ekind (Prev) = Ekind (Parent_Subp)
+ if Ekind (Prev) = Ekind (Parent_Subp)
and then Alias (Prev) = Parent_Subp
and then Scope (Parent_Subp) = Scope (Prev)
and then not Is_Hidden (Prev)
Desig_Typ := Full_View (Desig_Typ);
end if;
- if Base_Type (Desig_Typ) = Base_Type (Parent_Type) then
+ if Base_Type (Desig_Typ) = Base_Type (Parent_Type)
+
+ -- Ada 2005 (AI-251): Handle also derivations of abstract
+ -- interface primitives.
+
+ or else (Is_Interface (Desig_Typ)
+ and then not Is_Class_Wide_Type (Desig_Typ))
+ then
Acc_Type := New_Copy (Etype (Id));
Set_Etype (Acc_Type, Acc_Type);
Set_Scope (Acc_Type, New_Subp);
Set_Etype (New_Id, Base_Type (Derived_Type));
end if;
+ -- Ada 2005 (AI-251): Handle derivations of abstract interface
+ -- primitives.
+
+ elsif Is_Interface (Etype (Id))
+ and then not Is_Class_Wide_Type (Etype (Id))
+ then
+ Set_Etype (New_Id, Derived_Type);
+
else
Set_Etype (New_Id, Etype (Id));
end if;
then
Set_Derived_Name;
+ -- Ada 2005 (AI-251): Hidden entity associated with abstract interface
+ -- primitive
+
+ elsif Present (Abstract_Interface_Alias (Parent_Subp)) then
+ Set_Derived_Name;
+
-- The type is inheriting a private operation, so enter
-- it with a special name so it can't be overridden.
-- subprograms of untagged types simply get convention Ada by default.
if Is_Tagged_Type (Derived_Type) then
- Set_Convention (New_Subp, Convention (Parent_Subp));
+ Set_Convention (New_Subp, Convention (Parent_Subp));
end if;
Set_Is_Imported (New_Subp, Is_Imported (Parent_Subp));
(New_Subp, Is_Valued_Procedure (Parent_Subp));
end if;
+ -- No_Return must be inherited properly. If this is overridden in the
+ -- case of a dispatching operation, then a check is made in Sem_Disp
+ -- that the overriding operation is also No_Return (no such check is
+ -- required for the case of non-dispatching operation.
+
+ Set_No_Return (New_Subp, No_Return (Parent_Subp));
+
-- A derived function with a controlling result is abstract. If the
-- Derived_Type is a nonabstract formal generic derived type, then
-- inherited operations are not abstract: the required check is done at
and then Is_Dispatching_Operation (Parent_Subp)
then
Set_Is_Dispatching_Operation (New_Subp);
+
if Present (DTC_Entity (Parent_Subp)) then
Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
------------------------
procedure Derive_Subprograms
- (Parent_Type : Entity_Id;
- Derived_Type : Entity_Id;
- Generic_Actual : Entity_Id := Empty;
- Is_Interface_Derivation : Boolean := False)
+ (Parent_Type : Entity_Id;
+ Derived_Type : Entity_Id;
+ Generic_Actual : Entity_Id := Empty)
is
- Op_List : constant Elist_Id :=
- Collect_Primitive_Operations (Parent_Type);
- Act_List : Elist_Id;
- Act_Elmt : Elmt_Id;
- Elmt : Elmt_Id;
- Subp : Entity_Id;
- New_Subp : Entity_Id := Empty;
- Parent_Base : Entity_Id;
+ Op_List : constant Elist_Id :=
+ Collect_Primitive_Operations (Parent_Type);
+ Ifaces_List : constant Elist_Id := New_Elmt_List;
+ Act_List : Elist_Id;
+ Act_Elmt : Elmt_Id;
+ Elmt : Elmt_Id;
+ New_Subp : Entity_Id := Empty;
+ Parent_Base : Entity_Id;
+ Subp : Entity_Id;
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
Parent_Base := Parent_Type;
end if;
+ -- Derive primitives inherited from the parent
+
if Present (Generic_Actual) then
Act_List := Collect_Primitive_Operations (Generic_Actual);
Act_Elmt := First_Elmt (Act_List);
Subp := Node (Elmt);
if Ekind (Subp) /= E_Enumeration_Literal then
- if Is_Interface_Derivation then
- if not Is_Predefined_Dispatching_Operation (Subp) then
- Derive_Subprogram
- (New_Subp, Subp, Derived_Type, Parent_Base);
- end if;
+
+ if Ada_Version >= Ada_05
+ and then Present (Abstract_Interface_Alias (Subp))
+ then
+ null;
elsif No (Generic_Actual) then
- Derive_Subprogram
- (New_Subp, Subp, Derived_Type, Parent_Base);
+ Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base);
+
+ -- Ada 2005 (AI-251): Add the derivation of an abstract
+ -- interface primitive to the list of entities to which
+ -- we have to associate aliased entity.
+
+ if Ada_Version >= Ada_05
+ and then Is_Dispatching_Operation (Subp)
+ and then Present (Find_Dispatching_Type (Subp))
+ and then Is_Interface (Find_Dispatching_Type (Subp))
+ and then not Is_Predefined_Dispatching_Operation (Subp)
+ then
+ Append_Elmt (New_Subp, Ifaces_List);
+ end if;
else
- Derive_Subprogram (New_Subp, Subp,
- Derived_Type, Parent_Base, Node (Act_Elmt));
+ Derive_Subprogram
+ (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
Next_Elmt (Act_Elmt);
end if;
end if;
Next_Elmt (Elmt);
end loop;
+
+ Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
end Derive_Subprograms;
--------------------------------
-- we have to freeze it now. This is similar to what is done for
-- numeric types, and it equally suspicious, but otherwise a non-
-- static bound will have a reference to an unfrozen type, which is
- -- rejected by Gigi (???).
+ -- rejected by Gigi (???). This requires specific care for definition
+ -- of stream attributes. For details, see comments at the end of
+ -- Build_Derived_Numeric_Type.
Freeze_Before (N, Implicit_Base);
end Derived_Standard_Character;
and then Is_Non_Empty_List (Interface_List (Def))
then
declare
- I : Node_Id := First (Interface_List (Def));
- T : Entity_Id;
+ Intf : Node_Id;
+ T : Entity_Id;
+
begin
- while Present (I) loop
- T := Find_Type_Of_Subtype_Indic (I);
+ Intf := First (Interface_List (Def));
+ while Present (Intf) loop
+ T := Find_Type_Of_Subtype_Indic (Intf);
if not Is_Interface (T) then
- Error_Msg_NE ("(Ada 2005) & must be an interface", I, T);
+ Error_Msg_NE ("(Ada 2005) & must be an interface", Intf, T);
+
+ elsif Limited_Present (Def)
+ and then not Is_Limited_Interface (T)
+ then
+ Error_Msg_NE
+ ("progenitor interface& of limited type must be limited",
+ N, T);
end if;
- Next (I);
+ Next (Intf);
end loop;
end;
end if;
end if;
return;
+ end if;
+
+ -- Ada 2005 (AI-251): The case in which the parent of the full-view is
+ -- an interface is special because the list of interfaces in the full
+ -- view can be given in any order. For example:
+
+ -- type A is interface;
+ -- type B is interface and A;
+ -- type D is new B with private;
+ -- private
+ -- type D is new A and B with null record; -- 1 --
+
+ -- In this case we perform the following transformation of -1-:
- -- Ada 2005 (AI-231): Static check
+ -- type D is new B and A with null record;
- elsif Is_Access_Type (Parent_Type)
- and then Null_Exclusion_Present (Type_Definition (N))
- and then Can_Never_Be_Null (Parent_Type)
+ -- If the parent of the full-view covers the parent of the partial-view
+ -- we have two possible cases:
+
+ -- 1) They have the same parent
+ -- 2) The parent of the full-view implements some further interfaces
+
+ -- In both cases we do not need to perform the transformation. In the
+ -- first case the source program is correct and the transformation is
+ -- not needed; in the second case the source program does not fulfill
+ -- the no-hidden interfaces rule (AI-396) and the error will be reported
+ -- later.
+
+ -- This transformation not only simplifies the rest of the analysis of
+ -- this type declaration but also simplifies the correct generation of
+ -- the object layout to the expander.
+
+ if In_Private_Part (Current_Scope)
+ and then Is_Interface (Parent_Type)
then
- Error_Msg_N ("(Ada 2005) null exclusion not allowed if parent is "
- & "already non-null", Type_Definition (N));
+ declare
+ Iface : Node_Id;
+ Partial_View : Entity_Id;
+ Partial_View_Parent : Entity_Id;
+ New_Iface : Node_Id;
+
+ begin
+ -- Look for the associated private type declaration
+
+ Partial_View := First_Entity (Current_Scope);
+ loop
+ exit when No (Partial_View)
+ or else (Has_Private_Declaration (Partial_View)
+ and then Full_View (Partial_View) = T);
+
+ Next_Entity (Partial_View);
+ end loop;
+
+ -- If the partial view was not found then the source code has
+ -- errors and the transformation is not needed.
+
+ if Present (Partial_View) then
+ Partial_View_Parent := Etype (Partial_View);
+
+ -- If the parent of the full-view covers the parent of the
+ -- partial-view we have nothing else to do.
+
+ if Interface_Present_In_Ancestor
+ (Parent_Type, Partial_View_Parent)
+ then
+ null;
+
+ -- Traverse the list of interfaces of the full-view to look
+ -- for the parent of the partial-view and perform the tree
+ -- transformation.
+
+ else
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ if Etype (Iface) = Etype (Partial_View) then
+ Rewrite (Subtype_Indication (Def),
+ New_Copy (Subtype_Indication
+ (Parent (Partial_View))));
+
+ New_Iface := Make_Identifier (Sloc (N),
+ Chars (Parent_Type));
+ Append (New_Iface, Interface_List (Def));
+
+ -- Analyze the transformed code
+
+ Derived_Type_Declaration (T, N, Is_Completion);
+ return;
+ end if;
+
+ Next (Iface);
+ end loop;
+ end if;
+ end if;
+ end;
end if;
-- Only composite types other than array types are allowed to have
end if;
end if;
+ -- AI-443: Synchronized formal derived types require a private
+ -- extension. There is no point in checking the ancestor type or
+ -- the progenitors since the construct is wrong to begin with.
+
+ if Ada_Version >= Ada_05
+ and then Is_Generic_Type (T)
+ and then Present (Original_Node (N))
+ then
+ declare
+ Decl : constant Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (Decl) = N_Formal_Type_Declaration
+ and then Nkind (Formal_Type_Definition (Decl)) =
+ N_Formal_Derived_Type_Definition
+ and then Synchronized_Present (Formal_Type_Definition (Decl))
+ and then No (Extension)
+
+ -- Avoid emitting a duplicate error message
+
+ and then not Error_Posted (Indic)
+ then
+ Error_Msg_N
+ ("synchronized derived type must have extension", N);
+ end if;
+ end;
+ end if;
+
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
+
+ -- AI-419: The parent type of an explicitly limited derived type must
+ -- be a limited type or a limited interface.
+
+ if Limited_Present (Def) then
+ Set_Is_Limited_Record (T);
+
+ if Is_Interface (T) then
+ Set_Is_Limited_Interface (T);
+ end if;
+
+ if not Is_Limited_Type (Parent_Type)
+ and then
+ (not Is_Interface (Parent_Type)
+ or else not Is_Limited_Interface (Parent_Type))
+ then
+ Error_Msg_NE ("parent type& of limited type must be limited",
+ N, Parent_Type);
+ end if;
+ end if;
end Derived_Type_Declaration;
----------------------------------
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
+
+ elsif Ekind (Prev) = E_Record_Type_With_Private
+ and then
+ (Nkind (N) = N_Task_Type_Declaration
+ or else Nkind (N) = N_Protected_Type_Declaration)
+ then
+ if not Is_Limited_Record (Prev) then
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", N);
+
+ elsif No (Interface_List (N)) then
+ Error_Msg_N
+ ("completion of tagged private type must be tagged",
+ N);
+ end if;
end if;
-- Ada 2005 (AI-251): Private extension declaration of a
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
- Set_Is_Local_Anonymous_Access (T);
- -- comment here, what cases ???
+ if Nkind (Parent (Related_Nod)) /= N_Extended_Return_Statement then
+ Set_Is_Local_Anonymous_Access (T);
+ end if;
+
+ -- Otherwise, the object definition is just a subtype_mark
else
T := Process_Subtype (Obj_Def, Related_Nod);
if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
declare
- D : Entity_Id := First_Discriminant (Typ_For_Constraint);
- E : Elmt_Id := First_Elmt (Constraint);
+ D : Entity_Id;
+ E : Elmt_Id;
begin
+ D := First_Discriminant (Typ_For_Constraint);
+ E := First_Elmt (Constraint);
while Present (D) loop
if Chars (D) = Chars (Discriminant) then
return Node (E);
if Nkind (Result) = N_Defining_Identifier then
declare
- D : Entity_Id := First_Discriminant (Typ_For_Constraint);
- E : Elmt_Id := First_Elmt (Constraint);
+ D : Entity_Id;
+ E : Elmt_Id;
begin
+ D := First_Discriminant (Typ_For_Constraint);
+ E := First_Elmt (Constraint);
while Present (D) loop
if Corresponding_Discriminant (D) = Discriminant then
return Node (E);
Set_Parent (New_C, Parent (Old_C));
- -- Regular discriminants and components must be inserted
- -- in the scope of the Derived_Base. Do it here.
+ -- Regular discriminants and components must be inserted in the scope
+ -- of the Derived_Base. Do it here.
if not Stored_Discrim then
Enter_Name (New_C);
if Ekind (New_C) = E_Component then
if (Is_Private_Type (Derived_Base)
- and then not Is_Generic_Type (Derived_Base))
+ and then not Is_Generic_Type (Derived_Base))
or else (Is_Empty_Elmt_List (Discs)
- and then not Expander_Active)
+ and then not Expander_Active)
then
Set_Etype (New_C, Etype (Old_C));
+
else
- Set_Etype
- (New_C,
- Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
+ -- The current component introduces a circularity of the
+ -- following kind:
+
+ -- limited with Pack_2;
+ -- package Pack_1 is
+ -- type T_1 is tagged record
+ -- Comp : access Pack_2.T_2;
+ -- ...
+ -- end record;
+ -- end Pack_1;
+
+ -- with Pack_1;
+ -- package Pack_2 is
+ -- type T_2 is new Pack_1.T_1 with ...;
+ -- end Pack_2;
+
+ -- When Comp is being duplicated for type T_2, its designated
+ -- type must be set to point to the non-limited view of T_2.
+
+ if Ada_Version >= Ada_05
+ and then
+ Ekind (Etype (New_C)) = E_Anonymous_Access_Type
+ and then
+ Ekind (Directly_Designated_Type
+ (Etype (New_C))) = E_Incomplete_Type
+ and then
+ From_With_Type (Directly_Designated_Type (Etype (New_C)))
+ and then
+ Present (Non_Limited_View
+ (Directly_Designated_Type (Etype (New_C))))
+ and then
+ Non_Limited_View (Directly_Designated_Type
+ (Etype (New_C))) = Derived_Base
+ then
+ Set_Directly_Designated_Type
+ (Etype (New_C),
+ Non_Limited_View
+ (Directly_Designated_Type (Etype (New_C))));
+
+ else
+ Set_Etype
+ (New_C,
+ Constrain_Component_Type
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
+ end if;
end if;
end if;
while Present (Discrim) loop
Corr_Discrim := Corresponding_Discriminant (Discrim);
- -- Corr_Discrimm could be missing in an error situation
+ -- Corr_Discrim could be missing in an error situation
if Present (Corr_Discrim)
and then Original_Record_Component (Corr_Discrim) = Old_C
if Ekind (Component) = E_Component
and then Is_Tag (Component)
+ and then RTE_Available (RE_Interface_Tag)
and then Etype (Component) = RTE (RE_Interface_Tag)
then
null;
Next_Entity (Component);
end loop;
- -- For tagged derived types, inherited discriminants cannot be used in
- -- component declarations of the record extension part. To achieve this
- -- we mark the inherited discriminants as not visible.
+ -- For tagged derived types, inherited discriminants cannot be used in
+ -- component declarations of the record extension part. To achieve this
+ -- we mark the inherited discriminants as not visible.
+
+ if Is_Tagged and then Inherit_Discr then
+ D := First_Discriminant (Derived_Base);
+ while Present (D) loop
+ Set_Is_Immediately_Visible (D, False);
+ Next_Discriminant (D);
+ end loop;
+ end if;
+
+ return Assoc_List;
+ end Inherit_Components;
+
+ -----------------------
+ -- Is_Null_Extension --
+ -----------------------
+
+ function Is_Null_Extension (T : Entity_Id) return Boolean is
+ Full_Type_Decl : constant Node_Id := Parent (T);
+ Full_Type_Defn : constant Node_Id := Type_Definition (Full_Type_Decl);
+ Comp_List : Node_Id;
+ First_Comp : Node_Id;
+
+ begin
+ if not Is_Tagged_Type (T)
+ or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition
+ then
+ return False;
+ end if;
+
+ Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn));
+
+ if Present (Discriminant_Specifications (Full_Type_Decl)) then
+ return False;
+
+ elsif Present (Comp_List)
+ and then Is_Non_Empty_List (Component_Items (Comp_List))
+ then
+ First_Comp := First (Component_Items (Comp_List));
- if Is_Tagged and then Inherit_Discr then
- D := First_Discriminant (Derived_Base);
- while Present (D) loop
- Set_Is_Immediately_Visible (D, False);
- Next_Discriminant (D);
- end loop;
- end if;
+ return Chars (Defining_Identifier (First_Comp)) = Name_uParent
+ and then No (Next (First_Comp));
- return Assoc_List;
- end Inherit_Components;
+ else
+ return True;
+ end if;
+ end Is_Null_Extension;
------------------------------
-- Is_Valid_Constraint_Kind --
-------------------
function Is_Local_Type (Typ : Entity_Id) return Boolean is
- Scop : Entity_Id := Scope (Typ);
+ Scop : Entity_Id;
begin
+ Scop := Scope (Typ);
while Present (Scop)
and then Scop /= Standard_Standard
loop
Next_E : Entity_Id;
begin
- -- The class wide type can have been defined by the partial view in
- -- which case everything is already done
+ -- The class wide type can have been defined by the partial view, in
+ -- which case everything is already done.
if Present (Class_Wide_Type (T)) then
return;
Set_Chars (CW_Type, CW_Name);
Set_Parent (CW_Type, Parent (T));
Set_Next_Entity (CW_Type, Next_E);
+
+ -- Ensure we have a new freeze node for the class-wide type. The partial
+ -- view may have freeze action of its own, requiring a proper freeze
+ -- node, and the same freeze node cannot be shared between the two
+ -- types.
+
Set_Has_Delayed_Freeze (CW_Type);
+ Set_Freeze_Node (CW_Type, Empty);
-- Customize the class-wide type: It has no prim. op., it cannot be
-- abstract and its Etype points back to the specific root type.
begin
Get_First_Interp (I, Ind, It);
-
while Present (It.Typ) loop
if Is_Discrete_Type (It.Typ) then
-- Is order critical??? if so, document why, if not
-- use Analyze_And_Resolve
- Analyze (I);
+ Analyze_And_Resolve (I);
T := Etype (I);
- Resolve (I);
R := I;
-- If expander is inactive, type is legal, nothing else to construct
Append_Entity (Make_Op_Formal (Typ, Op), Op);
end New_Concatenation_Op;
+ -------------------------
+ -- OK_For_Limited_Init --
+ -------------------------
+
+ -- ???Check all calls of this, and compare the conditions under which it's
+ -- called.
+
+ function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
+ begin
+ return Ada_Version >= Ada_05
+ and then not Debug_Flag_Dot_L
+ and then OK_For_Limited_Init_In_05 (Exp);
+ end OK_For_Limited_Init;
+
+ -------------------------------
+ -- OK_For_Limited_Init_In_05 --
+ -------------------------------
+
+ function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is
+ begin
+ -- ???Expand_N_Extended_Return_Statement generates code that would
+ -- violate the rules in some cases. Once we have build-in-place
+ -- function returns working, we can probably remove the following
+ -- check.
+
+ if not Comes_From_Source (Exp) then
+ return True;
+ end if;
+
+ -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front-end in
+ -- case of limited aggregates (including extension aggregates),
+ -- and function calls.
+
+ case Nkind (Original_Node (Exp)) is
+ when N_Aggregate | N_Extension_Aggregate | N_Function_Call =>
+ return True;
+
+ when N_Qualified_Expression =>
+ return OK_For_Limited_Init_In_05
+ (Expression (Original_Node (Exp)));
+
+ when others =>
+ return False;
+ end case;
+ end OK_For_Limited_Init_In_05;
+
-------------------------------------------
-- Ordinary_Fixed_Point_Type_Declaration --
-------------------------------------------
-- of two that does not exceed the given delta value.
declare
- Tmp : Ureal := Ureal_1;
- Scale : Int := 0;
+ Tmp : Ureal;
+ Scale : Int;
begin
+ Tmp := Ureal_1;
+ Scale := 0;
+
if Delta_Val < Ureal_1 then
while Delta_Val < Tmp loop
Tmp := Tmp / Ureal_2;
end if;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
- Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
+ Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
-- Ada 2005 (AI-230): Access discriminants are now allowed for
-- nonlimited types, and are treated like other components of
Default_Not_Present := True;
end if;
- -- Ada 2005 (AI-231): Set the null-excluding attribute and carry
- -- out some static checks.
+ -- Ada 2005 (AI-231): Create an Itype that is a duplicate of
+ -- Discr_Type but with the null-exclusion attribute
- if Ada_Version >= Ada_05
- and then (Null_Exclusion_Present (Discr)
- or else Can_Never_Be_Null (Discr_Type))
- then
- Set_Can_Never_Be_Null (Defining_Identifier (Discr));
- Null_Exclusion_Static_Checks (Discr);
+ if Ada_Version >= Ada_05 then
+
+ -- Ada 2005 (AI-231): Static checks
+
+ if Can_Never_Be_Null (Discr_Type) then
+ Null_Exclusion_Static_Checks (Discr);
+
+ elsif Is_Access_Type (Discr_Type)
+ and then Null_Exclusion_Present (Discr)
+
+ -- No need to check itypes because in their case this check
+ -- was done at their point of creation
+
+ and then not Is_Itype (Discr_Type)
+ then
+ if Can_Never_Be_Null (Discr_Type) then
+ Error_Msg_N
+ ("null-exclusion cannot be applied to " &
+ "a null excluding type", Discr);
+ end if;
+
+ Set_Etype (Defining_Identifier (Discr),
+ Create_Null_Excluding_Itype
+ (T => Discr_Type,
+ Related_Nod => Discr));
+ end if;
+
+ -- Ada 2005 (AI-402): access discriminants of nonlimited types
+ -- can't have defaults
+
+ if Is_Access_Type (Discr_Type) then
+ if Ekind (Discr_Type) /= E_Anonymous_Access_Type
+ or else not Default_Present
+ or else Is_Limited_Record (Current_Scope)
+ or else Is_Concurrent_Type (Current_Scope)
+ or else Is_Concurrent_Record_Type (Current_Scope)
+ or else Ekind (Current_Scope) = E_Limited_Private_Type
+ then
+ null;
+ else
+ Error_Msg_N
+ ("(Ada 2005) access discriminants of nonlimited types",
+ Expression (Discr));
+ Error_Msg_N ("\cannot have defaults", Expression (Discr));
+ end if;
+ end if;
end if;
Next (Discr);
Discr := First (Discriminant_Specifications (N));
Discr_Number := Uint_1;
-
while Present (Discr) loop
Id := Defining_Identifier (Discr);
Set_Ekind (Id, E_Discriminant);
Full_Parent : Entity_Id;
Full_Indic : Node_Id;
- function Find_Interface_In_Descendant
- (Typ : Entity_Id) return Entity_Id;
- -- Find an implemented interface in the derivation chain of Typ
+ procedure Collect_Implemented_Interfaces
+ (Typ : Entity_Id;
+ Ifaces : Elist_Id);
+ -- Ada 2005: Gather all the interfaces that Typ directly or
+ -- inherently implements. Duplicate entries are not added to
+ -- the list Ifaces.
+
+ function Contain_Interface
+ (Iface : Entity_Id;
+ Ifaces : Elist_Id) return Boolean;
+ -- Ada 2005: Determine whether Iface is present in the list Ifaces
+
+ function Find_Hidden_Interface
+ (Src : Elist_Id;
+ Dest : Elist_Id) return Entity_Id;
+ -- Ada 2005: Determine whether the interfaces in list Src are all
+ -- present in the list Dest. Return the first differing interface,
+ -- or Empty otherwise.
+
+ ------------------------------------
+ -- Collect_Implemented_Interfaces --
+ ------------------------------------
+
+ procedure Collect_Implemented_Interfaces
+ (Typ : Entity_Id;
+ Ifaces : Elist_Id)
+ is
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
- ----------------------------------
- -- Find_Interface_In_Descendant --
- ----------------------------------
+ begin
+ -- Abstract interfaces are only associated with tagged record types
+
+ if not Is_Tagged_Type (Typ)
+ or else not Is_Record_Type (Typ)
+ then
+ return;
+ end if;
+
+ -- Recursively climb to the ancestors
+
+ if Etype (Typ) /= Typ
+
+ -- Protect the frontend against wrong cyclic declarations like:
+
+ -- type B is new A with private;
+ -- type C is new A with private;
+ -- private
+ -- type B is new C with null record;
+ -- type C is new B with null record;
+
+ and then Etype (Typ) /= Priv_T
+ and then Etype (Typ) /= Full_T
+ then
+ -- Keep separate the management of private type declarations
+
+ if Ekind (Typ) = E_Record_Type_With_Private then
+
+ -- Handle the following erronous case:
+ -- type Private_Type is tagged private;
+ -- private
+ -- type Private_Type is new Type_Implementing_Iface;
+
+ if Present (Full_View (Typ))
+ and then Etype (Typ) /= Full_View (Typ)
+ then
+ if Is_Interface (Etype (Typ))
+ and then not Contain_Interface (Etype (Typ), Ifaces)
+ then
+ Append_Elmt (Etype (Typ), Ifaces);
+ end if;
+
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
+ end if;
+
+ -- Non-private types
+
+ else
+ if Is_Interface (Etype (Typ))
+ and then not Contain_Interface (Etype (Typ), Ifaces)
+ then
+ Append_Elmt (Etype (Typ), Ifaces);
+ end if;
+
+ Collect_Implemented_Interfaces (Etype (Typ), Ifaces);
+ end if;
+ end if;
+
+ -- Handle entities in the list of abstract interfaces
+
+ if Present (Abstract_Interfaces (Typ)) then
+ Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- function Find_Interface_In_Descendant
- (Typ : Entity_Id) return Entity_Id
+ pragma Assert (Is_Interface (Iface));
+
+ if not Contain_Interface (Iface, Ifaces) then
+ Append_Elmt (Iface, Ifaces);
+ Collect_Implemented_Interfaces (Iface, Ifaces);
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Collect_Implemented_Interfaces;
+
+ -----------------------
+ -- Contain_Interface --
+ -----------------------
+
+ function Contain_Interface
+ (Iface : Entity_Id;
+ Ifaces : Elist_Id) return Boolean
is
- T : Entity_Id;
+ Iface_Elmt : Elmt_Id;
begin
- T := Typ;
- while T /= Etype (T) loop
- if Is_Interface (Etype (T)) then
- return Etype (T);
- end if;
+ if Present (Ifaces) then
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ return True;
+ end if;
- T := Etype (T);
- end loop;
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+
+ return False;
+ end Contain_Interface;
+
+ ---------------------------
+ -- Find_Hidden_Interface --
+ ---------------------------
+
+ function Find_Hidden_Interface
+ (Src : Elist_Id;
+ Dest : Elist_Id) return Entity_Id
+ is
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ if Present (Src) and then Present (Dest) then
+ Iface_Elmt := First_Elmt (Src);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if not Contain_Interface (Iface, Dest) then
+ return Iface;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
return Empty;
- end Find_Interface_In_Descendant;
+ end Find_Hidden_Interface;
-- Start of processing for Process_Full_View
Error_Msg_N ("generic type cannot have a completion", Full_T);
end if;
- -- Ada 2005 (AI-396): A full view shall be a descendant of an
- -- interface type if and only if the corresponding partial view
- -- (if any) is also a descendant of the interface type, or if
- -- the partial view is untagged.
+ -- Check that ancestor interfaces of private and full views are
+ -- consistent. We omit this check for synchronized types because
+ -- they are performed on thecorresponding record type when frozen.
if Ada_Version >= Ada_05
+ and then Is_Tagged_Type (Priv_T)
and then Is_Tagged_Type (Full_T)
+ and then Ekind (Full_T) /= E_Task_Type
+ and then Ekind (Full_T) /= E_Protected_Type
then
declare
- Iface : Entity_Id;
- Iface_Def : Node_Id;
+ Iface : Entity_Id;
+ Priv_T_Ifaces : constant Elist_Id := New_Elmt_List;
+ Full_T_Ifaces : constant Elist_Id := New_Elmt_List;
begin
- Iface := Find_Interface_In_Descendant (Full_T);
+ Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
+ Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
- if Present (Iface) then
- Iface_Def := Type_Definition (Parent (Iface));
- end if;
+ -- Ada 2005 (AI-251): The partial view shall be a descendant of
+ -- an interface type if and only if the full type is descendant
+ -- of the interface type (AARM 7.3 (7.3/2).
- -- The full view derives from an interface descendant, but the
- -- partial view does not share the same tagged type.
+ Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
- if Present (Iface)
- and then Is_Tagged_Type (Priv_T)
- and then Etype (Full_T) /= Etype (Priv_T)
- then
- Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
- "completed by a type that implements an " &
- "interface", Priv_T);
+ if Present (Iface) then
+ Error_Msg_NE ("interface & not implemented by full type " &
+ "('R'M'-2005 7.3 (7.3/2))", Priv_T, Iface);
end if;
- -- The full view derives from a limited, protected,
- -- synchronized or task interface descendant, but the
- -- partial view is not labeled as limited.
+ Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
- if Present (Iface)
- and then (Limited_Present (Iface_Def)
- or Protected_Present (Iface_Def)
- or Synchronized_Present (Iface_Def)
- or Task_Present (Iface_Def))
- and then not Limited_Present (Parent (Priv_T))
- then
- Error_Msg_N ("(Ada 2005) non-limited private type cannot be " &
- "completed by a limited type", Priv_T);
+ if Present (Iface) then
+ Error_Msg_NE ("interface & not implemented by partial view " &
+ "('R'M'-2005 7.3 (7.3/2))", Full_T, Iface);
end if;
end;
end if;
if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
return;
- elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
+ -- Ada 2005 (AI-251): Interfaces in the full-typ can be given in
+ -- any order. Therefore we don't have to check that its parent must
+ -- be a descendant of the parent of the private type declaration.
- -- Ada 2005 (AI-251): No error needed if the immediate
- -- ancestor of the partial view is an interface
- --
- -- Example:
- --
- -- type PT1 is new I1 with private;
- -- private
- -- type PT1 is new T and I1 with null record;
+ elsif Is_Interface (Priv_Parent)
+ and then Is_Interface (Full_Parent)
+ then
+ null;
- if Is_Interface (Base_Type (Priv_Parent)) then
- null;
+ -- Ada 2005 (AI-251): If the parent of the private type declaration
+ -- is an interface there is no need to check that it is an ancestor
+ -- of the associated full type declaration. The required tests for
+ -- this case case are performed by Build_Derived_Record_Type.
- else
- Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
- end if;
+ elsif not Is_Interface (Base_Type (Priv_Parent))
+ and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
+ then
+ Error_Msg_N
+ ("parent of full type must descend from parent"
+ & " of private extension", Full_Indic);
-- Check the rules of 7.3(10): if the private extension inherits
-- known discriminants, then the full type must also inherit those
-- subtype of the full type must be constrained if and only if
-- the ancestor subtype of the private extension is constrained.
- elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
+ elsif No (Discriminant_Specifications (Parent (Priv_T)))
and then not Has_Unknown_Discriminants (Priv_T)
and then Has_Discriminants (Base_Type (Priv_Parent))
then
begin
Priv_Discr := First_Discriminant (Priv_Parent);
Full_Discr := First_Discriminant (Full_Parent);
-
while Present (Priv_Discr) and then Present (Full_Discr) loop
if Original_Record_Component (Priv_Discr) =
Original_Record_Component (Full_Discr)
end if;
end if;
+ -- AI-419: verify that the use of "limited" is consistent
+
+ declare
+ Orig_Decl : constant Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then not Limited_Present (Parent (Priv_T))
+ and then not Synchronized_Present (Parent (Priv_T))
+ and then Nkind (Orig_Decl) = N_Full_Type_Declaration
+ and then Nkind
+ (Type_Definition (Orig_Decl)) = N_Derived_Type_Definition
+ and then Limited_Present (Type_Definition (Orig_Decl))
+ then
+ Error_Msg_N
+ ("full view of non-limited extension cannot be limited", N);
+ end if;
+ end;
+
+ -- Ada 2005 (AI-443): A synchronized private extension must be
+ -- completed by a task or protected type.
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
+ and then Synchronized_Present (Parent (Priv_T))
+ and then Ekind (Full_T) /= E_Task_Type
+ and then Ekind (Full_T) /= E_Protected_Type
+ then
+ Error_Msg_N ("full view of synchronized extension must " &
+ "be synchronized type", N);
+ end if;
+
-- Ada 2005 AI-363: if the full view has discriminants with
-- defaults, it is illegal to declare constrained access subtypes
-- whose designated type is the current type. This allows objects
and then not Has_Discriminants (Priv_T)
and then Has_Discriminants (Full_T)
and then
- Present
- (Discriminant_Default_Value (First_Discriminant (Full_T)))
+ Present (Discriminant_Default_Value (First_Discriminant (Full_T)))
then
Set_Has_Constrained_Partial_View (Full_T);
Set_Has_Constrained_Partial_View (Priv_T);
-- If the private view was tagged, copy the new Primitive
-- operations from the private view to the full view.
- if Is_Tagged_Type (Full_T) then
+ if Is_Tagged_Type (Full_T)
+ and then Ekind (Full_T) /= E_Task_Type
+ and then Ekind (Full_T) /= E_Protected_Type
+ then
declare
Priv_List : Elist_Id;
Full_List : constant Elist_Id := Primitive_Operations (Full_T);
end loop;
else
- -- In this case the partial view is untagged, so here we
- -- locate all of the earlier primitives that need to be
- -- treated as dispatching (those that appear between the two
- -- views). Note that these additional operations must all be
- -- new operations (any earlier operations that override
- -- inherited operations of the full view will already have
- -- been inserted in the primitives list and marked as
- -- dispatching by Check_Operation_From_Private_View. Note that
- -- implicit "/=" operators are excluded from being added to
- -- the primitives list since they shouldn't be treated as
- -- dispatching (tagged "/=" is handled specially).
+ -- In this case the partial view is untagged, so here we locate
+ -- all of the earlier primitives that need to be treated as
+ -- dispatching (those that appear between the two views). Note
+ -- that these additional operations must all be new operations
+ -- (any earlier operations that override inherited operations
+ -- of the full view will already have been inserted in the
+ -- primitives list, marked by Check_Operation_From_Private_View
+ -- as dispatching. Note that implicit "/=" operators are
+ -- excluded from being added to the primitives list since they
+ -- shouldn't be treated as dispatching (tagged "/=" is handled
+ -- specially).
Prim := Next_Entity (Full_T);
while Present (Prim) and then Prim /= Priv_T loop
and then D_Type /= Full_T
then
- -- Verify that it is not otherwise controlled by
- -- a formal or a return value ot type T.
+ -- Verify that it is not otherwise controlled by a
+ -- formal or a return value of type T.
Check_Controlling_Formals (D_Type, Prim);
end if;
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
- -- Any other attributes should be propagated to C_W ???
-
Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
-
end if;
end;
end if;
+
+ -- Ada 2005 AI 161: Check preelaboratable initialization consistency
+
+ if Known_To_Have_Preelab_Init (Priv_T) then
+
+ -- Case where there is a pragma Preelaborable_Initialization. We
+ -- always allow this in predefined units, which is a bit of a kludge,
+ -- but it means we don't have to struggle to meet the requirements in
+ -- the RM for having Preelaborable Initialization. Otherwise we
+ -- require that the type meets the RM rules. But we can't check that
+ -- yet, because of the rule about overriding Ininitialize, so we
+ -- simply set a flag that will be checked at freeze time.
+
+ if not In_Predefined_Unit (Full_T) then
+ Set_Must_Have_Preelab_Init (Full_T);
+ end if;
+ end if;
end Process_Full_View;
-----------------------------------
begin
if No (Private_Dependents (Inc_T)) then
return;
-
- else
- Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
-
- -- Itypes that may be generated by the completion of an incomplete
- -- subtype are not used by the back-end and not attached to the tree.
- -- They are created only for constraint-checking purposes.
end if;
+ -- Itypes that may be generated by the completion of an incomplete
+ -- subtype are not used by the back-end and not attached to the tree.
+ -- They are created only for constraint-checking purposes.
+
+ Inc_Elmt := First_Elmt (Private_Dependents (Inc_T));
while Present (Inc_Elmt) loop
Priv_Dep := Node (Inc_Elmt);
begin
Formal := First_Formal (Priv_Dep);
-
while Present (Formal) loop
-
if Etype (Formal) = Inc_T then
Set_Etype (Formal, Full_T);
end if;
end loop;
end;
- elsif Is_Overloadable (Priv_Dep) then
+ elsif Is_Overloadable (Priv_Dep) then
+
+ -- A protected operation is never dispatching: only its
+ -- wrapper operation (which has convention Ada) is.
- if Is_Tagged_Type (Full_T) then
+ if Is_Tagged_Type (Full_T)
+ and then Convention (Priv_Dep) /= Convention_Protected
+ then
-- Subprogram has an access parameter whose designated type
-- was incomplete. Reexamine declaration now, because it may
return;
+ -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a
+ -- corresponding subtype of the full view.
+
+ elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then
+ Set_Subtype_Indication
+ (Parent (Priv_Dep), New_Reference_To (Full_T, Sloc (Priv_Dep)));
+ Set_Etype (Priv_Dep, Full_T);
+ Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
+ Set_Analyzed (Parent (Priv_Dep), False);
+
+ -- Reanalyze the declaration, suppressing the call to
+ -- Enter_Name to avoid duplicate names.
+
+ Analyze_Subtype_Declaration
+ (N => Parent (Priv_Dep),
+ Skip => True);
+
-- Dependent is a subtype
else
Lo := Low_Bound (R);
Hi := High_Bound (R);
+ -- We need to ensure validity of the bounds here, because if we
+ -- go ahead and do the expansion, then the expanded code will get
+ -- analyzed with range checks suppressed and we miss the check.
+
+ Validity_Check_Range (R);
+
-- If there were errors in the declaration, try and patch up some
-- common mistakes in the bounds. The cases handled are literals
-- which are Integer where the expected type is Real and vice versa.
if not R_Check_Off then
R_Checks := Range_Check (R, T);
- Type_Decl := Parent (R);
-- Look up tree to find an appropriate insertion point.
-- This seems really junk code, and very brittle, couldn't
-- we just use an insert actions call of some kind ???
+ Type_Decl := Parent (R);
while Present (Type_Decl) and then not
(Nkind (Type_Decl) = N_Full_Type_Declaration
or else
if Nkind (Type_Decl) = N_Loop_Statement then
declare
- Indic : Node_Id := Parent (R);
+ Indic : Node_Id;
begin
+ Indic := Parent (R);
while Present (Indic) and then not
(Nkind (Indic) = N_Subtype_Indication)
loop
is
P : Node_Id;
Def_Id : Entity_Id;
+ Error_Node : Node_Id;
Full_View_Id : Entity_Id;
Subtype_Mark_Id : Entity_Id;
+ May_Have_Null_Exclusion : Boolean;
+
procedure Check_Incomplete (T : Entity_Id);
-- Called to verify that an incomplete type is not used prematurely
procedure Check_Incomplete (T : Entity_Id) is
begin
- if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
+ -- Ada 2005 (AI-412): Incomplete subtypes are legal
+
+ if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type
+ and then
+ not (Ada_Version >= Ada_05
+ and then
+ (Nkind (Parent (T)) = N_Subtype_Declaration
+ or else
+ (Nkind (Parent (T)) = N_Subtype_Indication
+ and then Nkind (Parent (Parent (T))) =
+ N_Subtype_Declaration)))
+ then
Error_Msg_N ("invalid use of type before its full declaration", T);
end if;
end Check_Incomplete;
Find_Type (S);
Check_Incomplete (S);
+ P := Parent (S);
-- Ada 2005 (AI-231): Static check
if Ada_Version >= Ada_05
- and then Present (Parent (S))
- and then Null_Exclusion_Present (Parent (S))
- and then Nkind (Parent (S)) /= N_Access_To_Object_Definition
+ and then Present (P)
+ and then Null_Exclusion_Present (P)
+ and then Nkind (P) /= N_Access_To_Object_Definition
and then not Is_Access_Type (Entity (S))
then
Error_Msg_N
- ("(Ada 2005) null-exclusion part requires an access type", S);
+ ("null-exclusion must be applied to an access type", S);
+ end if;
+
+ May_Have_Null_Exclusion :=
+ Nkind (P) = N_Access_Definition
+ or else Nkind (P) = N_Access_Function_Definition
+ or else Nkind (P) = N_Access_Procedure_Definition
+ or else Nkind (P) = N_Access_To_Object_Definition
+ or else Nkind (P) = N_Allocator
+ or else Nkind (P) = N_Component_Definition
+ or else Nkind (P) = N_Derived_Type_Definition
+ or else Nkind (P) = N_Discriminant_Specification
+ or else Nkind (P) = N_Object_Declaration
+ or else Nkind (P) = N_Parameter_Specification
+ or else Nkind (P) = N_Subtype_Declaration;
+
+ -- Create an Itype that is a duplicate of Entity (S) but with the
+ -- null-exclusion attribute
+
+ if May_Have_Null_Exclusion
+ and then Is_Access_Type (Entity (S))
+ and then Null_Exclusion_Present (P)
+
+ -- No need to check the case of an access to object definition.
+ -- It is correct to define double not-null pointers.
+
+ -- Example:
+ -- type Not_Null_Int_Ptr is not null access Integer;
+ -- type Acc is not null access Not_Null_Int_Ptr;
+
+ and then Nkind (P) /= N_Access_To_Object_Definition
+ then
+ if Can_Never_Be_Null (Entity (S)) then
+ case Nkind (Related_Nod) is
+ when N_Full_Type_Declaration =>
+ if Nkind (Type_Definition (Related_Nod))
+ in N_Array_Type_Definition
+ then
+ Error_Node :=
+ Subtype_Indication
+ (Component_Definition
+ (Type_Definition (Related_Nod)));
+ else
+ Error_Node :=
+ Subtype_Indication (Type_Definition (Related_Nod));
+ end if;
+
+ when N_Subtype_Declaration =>
+ Error_Node := Subtype_Indication (Related_Nod);
+
+ when N_Object_Declaration =>
+ Error_Node := Object_Definition (Related_Nod);
+
+ when N_Component_Declaration =>
+ Error_Node :=
+ Subtype_Indication (Component_Definition (Related_Nod));
+
+ when others =>
+ pragma Assert (False);
+ Error_Node := Related_Nod;
+ end case;
+
+ Error_Msg_N
+ ("null-exclusion cannot be applied to " &
+ "a null excluding type", Error_Node);
+ end if;
+
+ Set_Etype (S,
+ Create_Null_Excluding_Itype
+ (T => Entity (S),
+ Related_Nod => P));
+ Set_Entity (S, Etype (S));
end if;
+
return Entity (S);
-- Case of constraint present, so that we have an N_Subtype_Indication
-- node (this node is created only if constraints are present).
else
-
Find_Type (Subtype_Mark (S));
if Nkind (Parent (S)) /= N_Access_To_Object_Definition
and then not
(Nkind (Parent (S)) = N_Subtype_Declaration
- and then
- Is_Itype (Defining_Identifier (Parent (S))))
+ and then Is_Itype (Defining_Identifier (Parent (S))))
then
Check_Incomplete (Subtype_Mark (S));
end if;
Set_Entity (Subtype_Mark (S), Subtype_Mark_Id);
Set_Full_View (Def_Id, Full_View_Id);
+ -- Introduce an explicit reference to the private subtype,
+ -- to prevent scope anomalies in gigi if first use appears
+ -- in a nested context, e.g. a later function body.
+ -- Should this be generated in other contexts than a full
+ -- type declaration?
+
+ if Is_Itype (Def_Id)
+ and then
+ Nkind (Parent (P)) = N_Full_Type_Declaration
+ then
+ declare
+ Ref_Node : Node_Id;
+ begin
+ Ref_Node := Make_Itype_Reference (Sloc (Related_Nod));
+ Set_Itype (Ref_Node, Def_Id);
+ Insert_After (Parent (P), Ref_Node);
+ end;
+ end if;
+
else
Prepare_Private_Subtype_Completion (Def_Id, Related_Nod);
end if;
-- to a component, so that accessibility checks are properly performed
-- on it. The declaration of the access type is placed ahead of that
-- of the record, to prevent circular order-of-elaboration issues in
- -- gigi. We create an incomplete type for the record declaration, which
+ -- Gigi. We create an incomplete type for the record declaration, which
-- is the designated type of the anonymous access.
procedure Make_Incomplete_Type_Declaration;
Anon_Access : Entity_Id;
Acc_Def : Node_Id;
Comp : Node_Id;
+ Comp_Def : Node_Id;
Decl : Node_Id;
Type_Def : Node_Id;
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Chars (T);
+
+ -- A reference to the current type may appear as the prefix
+ -- of a 'Class attribute.
+
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
+ and then Is_Entity_Name (Prefix (Subt))
then
return (Chars (Prefix (Subt))) = Chars (T);
else
Comp := First (Component_Items (Comp_List));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration
- and then
- Present (Access_Definition (Component_Definition (Comp)))
+ and then Present
+ (Access_Definition (Component_Definition (Comp)))
and then
Mentions_T (Access_Definition (Component_Definition (Comp)))
then
+ Comp_Def := Component_Definition (Comp);
Acc_Def :=
Access_To_Subprogram_Definition
- (Access_Definition (Component_Definition (Comp)));
+ (Access_Definition (Comp_Def));
Make_Incomplete_Type_Declaration;
Anon_Access :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications =>
Parameter_Specifications (Acc_Def),
- Subtype_Mark => Subtype_Mark (Acc_Def));
+ Result_Definition => Result_Definition (Acc_Def));
else
Type_Def :=
Make_Access_Procedure_Definition (Loc,
Subtype_Indication =>
Relocate_Node
(Subtype_Mark
- (Access_Definition
- (Component_Definition (Comp)))));
+ (Access_Definition (Comp_Def))));
end if;
Decl := Make_Full_Type_Declaration (Loc,
Insert_Before (N, Decl);
Analyze (Decl);
- Set_Access_Definition (Component_Definition (Comp), Empty);
- Set_Subtype_Indication (Component_Definition (Comp),
- New_Occurrence_Of (Anon_Access, Loc));
+ -- If an access to object, Preserve entity of designated type,
+ -- for ASIS use, before rewriting the component definition.
+
+ if No (Acc_Def) then
+ declare
+ Desig : Entity_Id;
+
+ begin
+ Desig := Entity (Subtype_Indication (Type_Def));
+
+ -- If the access definition is to the current record,
+ -- the visible entity at this point is an incomplete
+ -- type. Retrieve the full view to simplify ASIS queries
+
+ if Ekind (Desig) = E_Incomplete_Type then
+ Desig := Full_View (Desig);
+ end if;
+
+ Set_Entity
+ (Subtype_Mark (Access_Definition (Comp_Def)), Desig);
+ end;
+ end if;
+
+ Rewrite (Comp_Def,
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Anon_Access, Loc)));
Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
Set_Is_Local_Anonymous_Access (Anon_Access);
end if;
H : Entity_Id;
begin
- -- If there is a previous partial view, no need to create a new one.
+ -- If there is a previous partial view, no need to create a new one
+ -- If the partial view is incomplete, it is given by Prev. If it is
+ -- a private declaration, full declaration is flagged accordingly.
- if Prev /= T then
+ if Prev /= T
+ or else Has_Private_Declaration (T)
+ then
return;
elsif No (Inc_T) then
-- Type has already been inserted into the current scope.
-- Remove it, and add incomplete declaration for type, so
-- that subsequent anonymous access types can use it.
+ -- The entity is unchained from the homonym list and from
+ -- immediate visibility. After analysis, the entity in the
+ -- incomplete declaration becomes immediately visible in the
+ -- record declaration that follows.
H := Current_Entity (T);
if H = T then
- Set_Name_Entity_Id (Chars (T), Empty);
+ Set_Name_Entity_Id (Chars (T), Homonym (T));
else
while Present (H)
and then Homonym (H) /= T
if Tagged_Present (Def) then
Make_Class_Wide_Type (Inc_T);
Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T));
+ Set_Etype (Class_Wide_Type (T), T);
end if;
end if;
end Make_Incomplete_Type_Declaration;
else
Is_Tagged := True;
- Set_Is_Tagged_Type (T);
-
- Set_Is_Limited_Record (T, Limited_Present (Def)
- or else Task_Present (Def)
- or else Protected_Present (Def));
+ Analyze_Interface_Declaration (T, Def);
- -- Type is abstract if full declaration carries keyword, or if
- -- previous partial view did.
-
- Set_Is_Abstract (T);
- Set_Is_Interface (T);
+ if Present (Discriminant_Specifications (N)) then
+ Error_Msg_N
+ ("interface types cannot have discriminants",
+ Defining_Identifier
+ (First (Discriminant_Specifications (N))));
+ end if;
end if;
-- First pass: if there are self-referential access components,
Check_Anonymous_Access_Types (Component_List (Def));
- -- Ada 2005 (AI-251): Complete the initialization of attributes
- -- associated with abstract interfaces and decorate the names in the
- -- list of ancestor interfaces (if any).
-
if Ada_Version >= Ada_05
and then Present (Interface_List (Def))
then
declare
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ Ifaces_List : Elist_Id;
+
begin
Iface := First (Interface_List (Def));
-
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
Next (Iface);
end loop;
- Set_Abstract_Interfaces (T, New_Elmt_List);
- Collect_Interfaces (Type_Definition (N), T);
+ -- Ada 2005 (AI-251): Collect the list of progenitors that are not
+ -- already in the parents.
+
+ Collect_Abstract_Interfaces
+ (T => T,
+ Ifaces_List => Ifaces_List,
+ Exclude_Parent_Interfaces => True);
+
+ Set_Abstract_Interfaces (T, Ifaces_List);
end;
end if;
-- must reset the Suppress_Range_Checks flags after having processed
-- the record definition.
+ -- Note: this is the only use of Kill_Range_Checks, and is a bit odd,
+ -- couldn't we just use the normal range check suppression method here.
+ -- That would seem cleaner ???
+
if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then
Set_Kill_Range_Checks (T, True);
Record_Type_Definition (Def, Prev);
End_Scope;
- if Expander_Active
- and then Is_Tagged
+ -- Ada 2005 (AI-251 and AI-345): Derive the interface subprograms of all
+ -- the implemented interfaces and associate them an aliased entity.
+
+ if Is_Tagged
and then not Is_Empty_List (Interface_List (Def))
then
- -- Ada 2005 (AI-251): Derive the interface subprograms of all the
- -- implemented interfaces and check if some of the subprograms
- -- inherited from the ancestor cover some interface subprogram.
-
- Derive_Interface_Subprograms (T);
+ declare
+ Ifaces_List : constant Elist_Id := New_Elmt_List;
+ begin
+ Derive_Interface_Subprograms (T, T, Ifaces_List);
+ end;
end if;
end Record_Type_Declaration;
Final_Storage_Only := not Is_Controlled (T);
+ -- Ada 2005: check whether an explicit Limited is present in a derived
+ -- type declaration.
+
+ if Nkind (Parent (Def)) = N_Derived_Type_Definition
+ and then Limited_Present (Parent (Def))
+ then
+ Set_Is_Limited_Record (T);
+ end if;
+
-- If the component list of a record type is defined by the reserved
-- word null and there is no discriminant part, then the record type has
-- no components and all records of the type are null records (RM 3.7)
begin
if Nkind (N) = N_Discriminant_Specification then
Comp := First_Discriminant (Typ);
-
while Present (Comp) loop
if Chars (Comp) = Chars (Defining_Identifier (N)) then
Set_Defining_Identifier (N, Comp);
elsif Nkind (N) = N_Component_Declaration then
Comp := First_Component (Typ);
-
while Present (Comp) loop
if Chars (Comp) = Chars (Defining_Identifier (N)) then
Set_Defining_Identifier (N, Comp);
OSDN Git Service
