-- Spec_PPC_List Node24
- -- Abstract_Interface_Alias Node25
- -- Abstract_Interfaces Elist25
+ -- Interface_Alias Node25
+ -- Interfaces Elist25
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
-- Attribute Access Functions --
--------------------------------
- function Abstract_Interfaces (Id : E) return L is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Elist25 (Id);
- end Abstract_Interfaces;
-
- function Abstract_Interface_Alias (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Node25 (Id);
- end Abstract_Interface_Alias;
-
function Accept_Address (Id : E) return L is
begin
return Elist21 (Id);
return Flag232 (Id);
end Implemented_By_Entry;
+ function Interfaces (Id : E) return L is
+ begin
+ pragma Assert (Is_Record_Type (Id));
+ return Elist25 (Id);
+ end Interfaces;
+
+ function Interface_Alias (Id : E) return E is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Node25 (Id);
+ end Interface_Alias;
+
function In_Package_Body (Id : E) return B is
begin
return Flag48 (Id);
-- Attribute Set Procedures --
------------------------------
- procedure Set_Abstract_Interfaces (Id : E; V : L) is
- begin
- pragma Assert (Is_Record_Type (Id));
- Set_Elist25 (Id, V);
- end Set_Abstract_Interfaces;
-
- procedure Set_Abstract_Interface_Alias (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Hidden (Id)
- and then
- (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function));
- Set_Node25 (Id, V);
- end Set_Abstract_Interface_Alias;
-
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
Set_Flag232 (Id, V);
end Set_Implemented_By_Entry;
+ procedure Set_Interfaces (Id : E; V : L) is
+ begin
+ pragma Assert (Is_Record_Type (Id));
+ Set_Elist25 (Id, V);
+ end Set_Interfaces;
+
+ procedure Set_Interface_Alias (Id : E; V : E) is
+ begin
+ pragma Assert
+ (Is_Internal (Id)
+ and then Is_Hidden (Id)
+ and then (Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Function));
+ Set_Node25 (Id, V);
+ end Set_Interface_Alias;
+
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
function Next_Tag_Component (Id : E) return E is
Comp : Entity_Id;
- Typ : constant Entity_Id := Scope (Id);
begin
- pragma Assert (Ekind (Id) = E_Component
- and then Is_Tagged_Type (Typ));
+ pragma Assert (Is_Tag (Id));
Comp := Next_Entity (Id);
while Present (Comp) loop
when E_Procedure |
E_Function =>
- Write_Str ("Abstract_Interface_Alias");
+ Write_Str ("Interface_Alias");
when E_Record_Type |
E_Record_Subtype |
E_Record_Type_With_Private |
E_Record_Subtype_With_Private =>
- Write_Str ("Abstract_Interfaces");
+ Write_Str ("Interfaces");
when Task_Kind =>
Write_Str ("Task_Body_Procedure");
-- type, and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
--- Abstract_Interfaces (Elist25)
--- Present in record types and subtypes. List of abstract interfaces
--- implemented by a tagged type that are not already implemented by the
--- ancestors (Ada 2005: AI-251).
-
--- Abstract_Interface_Alias (Node25)
--- Present in subprograms that cover a primitive operation of an abstract
--- interface type. Can be set only if the Is_Hidden flag is also set,
--- since such entities are always hidden. Points to its associated
--- interface subprogram. It is used to register the subprogram in
--- secondary dispatch table of the interface (Ada 2005: AI-251).
-
-- Accept_Address (Elist21)
-- Present in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
-- Alias (Node18)
-- Present in overloaded entities (literals, subprograms, entries) and
-- subprograms that cover a primitive operation of an abstract interface
--- (that is, subprograms with the Abstract_Interface_Alias attribute).
--- In case of overloaded entities it points to the parent subprogram of
--- a derived subprogram. In case of abstract interface subprograms it
--- points to the subprogram that covers the abstract interface primitive.
--- Also used for a subprogram renaming, where it points to the renamed
--- subprogram. Always empty for entries.
+-- (that is, subprograms with the Interface_Alias attribute). In case of
+-- overloaded entities it points to the parent subprogram of a derived
+-- subprogram. In case of abstract interface subprograms it points to the
+-- subprogram that covers the abstract interface primitive. Also used for
+-- a subprogram renaming, where it points to the renamed subprogram.
+-- Always empty for entries.
-- Alignment (Uint14)
-- Present in entities for types and also in constants, variables
-- Applies to functions and procedures. Set if pragma Implemented_By_
-- Entry is applied on the subprogram entity.
+-- Interfaces (Elist25)
+-- Present in record types and subtypes. List of abstract interfaces
+-- implemented by a tagged type that are not already implemented by the
+-- ancestors (Ada 2005: AI-251).
+
+-- Interface_Alias (Node25)
+-- Present in subprograms that cover a primitive operation of an abstract
+-- interface type. Can be set only if the Is_Hidden flag is also set,
+-- since such entities are always hidden. Points to its associated
+-- interface subprogram. It is used to register the subprogram in
+-- secondary dispatch table of the interface (Ada 2005: AI-251).
+
-- In_Package_Body (Flag48)
-- Present in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
-- 3) Object declarations generated by the expander that are implicitly
-- imported or exported so that they can be marked in Sprint output.
--
+-- 4) Internal entities in the list of primitives of tagged types that
+-- are used to handle secondary dispatch tables. These entities have
+-- also the attribute Interface_Alias.
+--
-- Is_Interrupt_Handler (Flag89)
-- Present in procedures. Set if a pragma Interrupt_Handler applies
-- to the procedure. The procedure must be parameterless, and on all
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic function only)
-- Protection_Object (Node23) (for concurrent kind)
- -- Abstract_Interface_Alias (Node25)
+ -- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Extra_Formals (Node28)
-- Body_Needed_For_SAL (Flag40)
-- Inner_Instances (Elist23) (for generic proc)
-- Protection_Object (Node23) (for concurrent kind)
-- Spec_PPC_List (Node24) (non-generic case only)
- -- Abstract_Interface_Alias (Node25)
+ -- Interface_Alias (Node25)
-- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- Stored_Constraint (Elist23)
- -- Abstract_Interfaces (Elist25)
+ -- Interfaces (Elist25)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
- -- Abstract_Interfaces (Elist25)
+ -- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
- function Abstract_Interfaces (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
- function Abstract_Interface_Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Final_Chain (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
function Inner_Instances (Id : E) return L;
+ function Interfaces (Id : E) return L;
+ function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
-- Attribute Set Procedures --
------------------------------
- procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
- procedure Set_Abstract_Interface_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Final_Chain (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
procedure Set_Implemented_By_Entry (Id : E; V : B := True);
+ procedure Set_Interfaces (Id : E; V : L);
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
procedure Set_Inner_Instances (Id : E; V : L);
+ procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
- pragma Inline (Abstract_Interfaces);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
- pragma Inline (Abstract_Interface_Alias);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Final_Chain);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
pragma Inline (Implemented_By_Entry);
+ pragma Inline (Interfaces);
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
pragma Inline (Inner_Instances);
+ pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
- pragma Inline (Set_Abstract_Interfaces);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
- pragma Inline (Set_Abstract_Interface_Alias);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Final_Chain);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
pragma Inline (Set_Implemented_By_Entry);
+ pragma Inline (Set_Interfaces);
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
pragma Inline (Set_Inner_Instances);
+ pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract_Subprogram);
-- Ada 2005 (AI-251): If tagged type has progenitors we must
-- also initialize tags of the secondary dispatch tables.
- if Has_Abstract_Interfaces (Base_Type (Typ)) then
+ if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
-- abstract interfaces we must also initialize the tags of the
-- secondary dispatch tables.
- if Has_Abstract_Interfaces (Base_Type (Typ)) then
+ if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
-- If the tagged types covers interface types we need to initialize all
-- hidden components containing pointers to secondary dispatch tables.
- elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
+ elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
Convert_To_Assignments (N, Typ);
-- If some components are mutable, the size of the aggregate component
-- its secondary dispatch table and therefore the code generator
-- has nothing else to do with this freezing node.
- Delete := Present (Abstract_Interface_Alias (E));
+ Delete := Present (Interface_Alias (E));
end if;
-- Analyze actions generated by freezing. The init_proc contains source
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
-- If the interface is a parent of Rec_Type it shares the primary
-- dispatch table and hence there is no need to build the function
- if not Is_Parent (Node (Iface_Elmt), Rec_Type) then
+ if not Is_Ancestor (Node (Iface_Elmt), Rec_Type) then
Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt));
end if;
if Ada_Version >= Ada_05
and then not Is_Interface (Rec_Type)
- and then Has_Abstract_Interfaces (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
then
Init_Secondary_Tags
(Typ => Rec_Type,
if not Is_Imported (Prim)
and then Convention (Prim) = Convention_CPP
- and then not Present (Abstract_Interface_Alias
- (Prim))
+ and then not Present (Interface_Alias (Prim))
then
Register_Primitive (Loc,
Prim => Prim,
if Ada_Version >= Ada_05
and then not Is_Interface (Rec_Type)
- and then Has_Abstract_Interfaces (Rec_Type)
+ and then Has_Interfaces (Rec_Type)
and then Has_Discriminants (Etype (Rec_Type))
and then Is_Variable_Size_Record (Etype (Rec_Type))
then
and then
(Is_Class_Wide_Type (Etype (Expr))
or else
- not Is_Parent (Root_Type (Typ), Etype (Expr)))
+ not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
and then Comes_From_Source (Def_Id)
and then VM_Target = No_VM
then
------------------------
procedure Freeze_Record_Type (N : Node_Id) is
+
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id);
+ -- Add to the list of primitives of Tagged_Types the internal entities
+ -- associated with interface primitives that are located in secondary
+ -- dispatch tables.
+
+ -------------------------------------
+ -- Add_Internal_Interface_Entities --
+ -------------------------------------
+
+ procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
+ Ifaces_List : Elist_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim : Entity_Id;
+
+ begin
+ pragma Assert (Ada_Version >= Ada_05
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type)
+ and then not Is_Interface (Tagged_Type));
+
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ -- Exclude from this processing interfaces that are parents
+ -- of Tagged_Type because their primitives are located in the
+ -- primary dispatch table (and hence no auxiliary internal
+ -- entities are required to handle secondary dispatch tables
+ -- in such case).
+
+ if not Is_Ancestor (Iface, Tagged_Type) then
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+ Prim :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Prim);
+
+ pragma Assert (Present (Prim));
+
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Iface_Prim,
+ Derived_Type => Tagged_Type,
+ Parent_Type => Iface);
+
+ -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+ -- associated with interface types. These entities are
+ -- only registered in the list of primitives of its
+ -- corresponding tagged type because they are only used
+ -- to fill the contents of the secondary dispatch tables.
+ -- Therefore they are removed from the homonym chains.
+
+ Set_Is_Hidden (New_Subp);
+ Set_Is_Internal (New_Subp);
+ Set_Alias (New_Subp, Prim);
+ Set_Is_Abstract_Subprogram (New_Subp,
+ Is_Abstract_Subprogram (Prim));
+ Set_Interface_Alias (New_Subp, Iface_Prim);
+
+ -- Internal entities associated with interface types are
+ -- only registered in the list of primitives of the
+ -- tagged type. They are only used to fill the contents
+ -- of the secondary dispatch tables. Therefore they are
+ -- not needed in the homonym chains.
+
+ Remove_Homonym (New_Subp);
+
+ -- Hidden entities associated with interfaces must have
+ -- set the Has_Delay_Freeze attribute to ensure that, in
+ -- case of locally defined tagged types (or compiling
+ -- with static dispatch tables generation disabled) the
+ -- corresponding entry of the secondary dispatch table is
+ -- filled when such entity is frozen.
+
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end Add_Internal_Interface_Entities;
+
+ -- Local variables
+
Def_Id : constant Node_Id := Entity (N);
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
Wrapper_Body_List : List_Id := No_List;
Null_Proc_Decl_List : List_Id := No_List;
+ -- Start of processing for Freeze_Record_Type
+
begin
-- Build discriminant checking functions if not a derived type (for
-- derived types that are not tagged types, always use the discriminant
Insert_Actions (N, Null_Proc_Decl_List);
end if;
+ -- Ada 2005 (AI-251): Add internal entities associated with
+ -- secondary dispatch tables to the list of primitives of tagged
+ -- types that are not interfaces
+
+ if Ada_Version >= Ada_05
+ and then not Is_Interface (Def_Id)
+ and then Has_Interfaces (Def_Id)
+ then
+ Add_Internal_Interface_Entities (Def_Id);
+ end if;
+
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
-- Initialize the pointer to the secondary DT associated with the
-- interface.
- if not Is_Parent (Iface, Typ) then
+ if not Is_Ancestor (Iface, Typ) then
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
-- Don't need to set any value if this interface shares
-- the primary dispatch table.
- if not Is_Parent (Iface, Typ) then
+ if not Is_Ancestor (Iface, Typ) then
Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag => New_Reference_To (Iface_Tag, Loc),
-- User-defined equality
elsif Chars (Node (Prim)) = Name_Op_Eq
- and then (No (Alias (Node (Prim)))
- or else Nkind (Unit_Declaration_Node (Node (Prim))) =
- N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
then
- Eq_Needed := False;
- exit;
+ if No (Alias (Node (Prim)))
+ or else Nkind (Unit_Declaration_Node (Node (Prim))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ Eq_Needed := False;
+ exit;
- -- If the parent is not an interface type and has an abstract
- -- equality function, the inherited equality is abstract as well,
- -- and no body can be created for it.
+ -- If the parent is not an interface type and has an abstract
+ -- equality function, the inherited equality is abstract as
+ -- well, and no body can be created for it.
- elsif Chars (Node (Prim)) = Name_Op_Eq
- and then not Is_Interface (Etype (Tag_Typ))
- and then Present (Alias (Node (Prim)))
- and then Is_Abstract_Subprogram (Alias (Node (Prim)))
- then
- Eq_Needed := False;
- exit;
+ elsif not Is_Interface (Etype (Tag_Typ))
+ and then Present (Alias (Node (Prim)))
+ and then Is_Abstract_Subprogram (Alias (Node (Prim)))
+ then
+ Eq_Needed := False;
+ exit;
+
+ -- If the type has an equality function corresponding with
+ -- a primitive defined in an interface type, the inherited
+ -- equality is abstract as well, and no body can be created
+ -- for it.
+
+ elsif Present (Alias (Node (Prim)))
+ and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
+ and then
+ Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
+ then
+ Eq_Needed := False;
+ exit;
+ end if;
end if;
Next_Elmt (Prim);
and then Is_Limited_Record (Etype (Tag_Typ)))
or else
(Is_Concurrent_Record_Type (Tag_Typ)
- and then Has_Abstract_Interfaces (Tag_Typ))
+ and then Has_Interfaces (Tag_Typ))
then
Append_To (Res,
Make_Subprogram_Declaration (Loc,
((Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else (Is_Concurrent_Record_Type (Tag_Typ)
- and then Has_Abstract_Interfaces (Tag_Typ)))
+ and then Has_Interfaces (Tag_Typ)))
and then RTE_Available (RE_Select_Specific_Data)
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));
-- Obj1 in Iface'Class; -- Compile time error
if not Is_Class_Wide_Type (Left_Type)
- and then (Is_Parent (Etype (Right_Type), Left_Type)
+ and then (Is_Ancestor (Etype (Right_Type), Left_Type)
or else (Is_Interface (Etype (Right_Type))
and then Interface_Present_In_Ancestor
(Typ => Left_Type,
Tagged_Typ := Find_Dispatching_Type (Prim);
if No (Access_Disp_Table (Tagged_Typ))
- or else not Has_Abstract_Interfaces (Tagged_Typ)
+ or else not Has_Interfaces (Tagged_Typ)
or else not RTE_Available (RE_Interface_Tag)
or else Restriction_Active (No_Dispatching_Calls)
then
-- table slot.
if not Is_Interface (Typ)
- or else Present (Abstract_Interface_Alias (Subp))
+ or else Present (Interface_Alias (Subp))
then
if Is_Predefined_Dispatching_Operation (Subp) then
Register_Predefined_DT_Entry (Subp);
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
+with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
Iface := Etype (Iface);
end loop Examine_Parents;
- if Present (Abstract_Interfaces
+ if Present (Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))))
then
Iface_Elmt := First_Elmt
- (Abstract_Interfaces
+ (Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))));
Examine_Interfaces : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- an interface.
if Ada_Version >= Ada_05
- and then Present (Abstract_Interfaces (
+ and then Present (Interfaces (
Corresponding_Record_Type (Pid)))
then
Disp_Op_Body :=
if Ada_Version >= Ada_05
and then Present (Protected_Definition (Parent (Pid)))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type (Pid)))
+ and then Present (Interfaces (Corresponding_Record_Type (Pid)))
then
declare
Vis_Decl : Node_Id :=
if Ada_Version >= Ada_05
and then Present (Visible_Declarations (Pdef))
and then Present (Corresponding_Record_Type
- (Defining_Identifier (Parent (Pdef))))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type
- (Defining_Identifier (Parent (Pdef)))))
+ (Defining_Identifier (Parent (Pdef))))
+ and then Present (Interfaces
+ (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Pdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
if Ada_Version >= Ada_05
and then
- Present (Abstract_Interfaces
- (Corresponding_Record_Type (Prot_Typ)))
+ Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
Sub :=
Make_Subprogram_Declaration (Loc,
if Ada_Version >= Ada_05
and then Present (Task_Definition (Parent (Ttyp)))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type (Ttyp)))
+ and then Present (Interfaces (Corresponding_Record_Type (Ttyp)))
then
declare
Current_Node : Node_Id;
if Ada_Version >= Ada_05
and then Present (Taskdef)
and then Present (Corresponding_Record_Type
- (Defining_Identifier (Parent (Taskdef))))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type
- (Defining_Identifier (Parent (Taskdef)))))
+ (Defining_Identifier (Parent (Taskdef))))
+ and then Present (Interfaces
+ (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Taskdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
declare
L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
-
begin
if Is_Non_Empty_List (L) then
Insert_List_After (Body_Decl, L);
if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
- or else Has_Abstract_Interfaces (Protect_Rec)
+ or else Has_Interfaces (Protect_Rec)
then
declare
Pkg_Id : constant RTU_Id :=
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Parent (Formal_Typ, Actual_Typ) then
+ elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
null;
-- Implicit conversion to the class-wide formal type to force
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
- elsif Is_Parent (Formal_DDT, Actual_DDT) then
+ elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
null;
else
and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
+ -----------------------------------------
+ -- Is_Predefined_Dispatching_Operation --
+ -----------------------------------------
+
+ function Is_Predefined_Dispatching_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
+ .. Name_Len));
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Operation;
+
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
return False;
end Is_Predefined_Dispatching_Alias;
+ ---------------------------------------
+ -- Is_Predefined_Interface_Primitive --
+ ---------------------------------------
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ return Ada_Version >= Ada_05
+ and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
+ Chars (E) = Name_uDisp_Conditional_Select or else
+ Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
+ Chars (E) = Name_uDisp_Get_Task_Id or else
+ Chars (E) = Name_uDisp_Requeue or else
+ Chars (E) = Name_uDisp_Timed_Select);
+ end Is_Predefined_Interface_Primitive;
+
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
or else Is_Controlled (Typ)
or else Restriction_Active (No_Dispatching_Calls)
or else not Is_Limited_Type (Typ)
- or else not Has_Abstract_Interfaces (Typ)
+ or else not Has_Interfaces (Typ)
or else not Build_Thunks
then
-- No OSD table required
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
- if Present (Abstract_Interface_Alias (Prim))
+ if Present (Interface_Alias (Prim))
and then Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim)) = Iface
+ (Interface_Alias (Prim)) = Iface
then
- Prim_Alias := Abstract_Interface_Alias (Prim);
+ Prim_Alias := Interface_Alias (Prim);
E := Prim;
while Present (Alias (E)) loop
Prim := Node (Prim_Elmt);
if not Is_Predefined_Dispatching_Operation (Prim)
- and then Present (Abstract_Interface_Alias (Prim))
+ and then Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (Alias (Prim))
and then not Is_Imported (Alias (Prim))
and then Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim)) = Iface
+ (Interface_Alias (Prim)) = Iface
-- Generate the code of the thunk only if the abstract
-- interface type is not an immediate ancestor of
-- Tagged_Type; otherwise the DT associated with the
-- interface is the primary DT.
- and then not Is_Parent (Iface, Typ)
+ and then not Is_Ancestor (Iface, Typ)
then
if not Build_Thunks then
Pos :=
- UI_To_Int
- (DT_Position (Abstract_Interface_Alias (Prim)));
+ UI_To_Int (DT_Position (Interface_Alias (Prim)));
Prim_Table (Pos) := Alias (Prim);
else
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
Pos :=
- UI_To_Int
- (DT_Position (Abstract_Interface_Alias (Prim)));
+ UI_To_Int (DT_Position (Interface_Alias (Prim)));
Prim_Table (Pos) := Thunk_Id;
Append_To (Result, Thunk_Code);
-- Ada 2005 (AI-251): Build the secondary dispatch tables
- if Has_Abstract_Interfaces (Typ) then
+ if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
Suffix_Index := 0;
-- Count the number of interface types implemented by Typ
- Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
+ Collect_Interfaces (Typ, Typ_Ifaces);
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
begin
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
- if Is_Parent (Node (AI), Typ) then
+ if Is_Ancestor (Node (AI), Typ) then
Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc);
else
while Ekind (Node (Elmt)) = E_Constant
and then not
- Is_Parent (Node (AI), Related_Type (Node (Elmt)))
+ Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
if Ada_Version >= Ada_05
and then Has_DT (Typ)
and then Is_Concurrent_Record_Type (Typ)
- and then Has_Abstract_Interfaces (Typ)
+ and then Has_Interfaces (Typ)
and then Nb_Prim > 0
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
Prim := Node (Prim_Elmt);
if Is_Imported (Prim)
- or else Present (Abstract_Interface_Alias (Prim))
+ or else Present (Interface_Alias (Prim))
or else Is_Predefined_Dispatching_Operation (Prim)
then
null;
if not Is_Predefined_Dispatching_Operation (E)
and then not Is_Abstract_Subprogram (E)
- and then not Present (Abstract_Interface_Alias (E))
+ and then not Present (Interface_Alias (E))
then
pragma Assert
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
Copy_Secondary_DTs (Etype (Typ));
end if;
- if Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List
- (Abstract_Interfaces (Typ))
+ if Present (Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Interfaces (Typ))
then
- Iface := First_Elmt (Abstract_Interfaces (Typ));
+ Iface := First_Elmt (Interfaces (Typ));
E := First_Entity (Typ);
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
- and then Has_Abstract_Interfaces (Typ)
+ and then Has_Interfaces (Typ)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));
-- Look for primitive overriding an abstract interface subprogram
- if Present (Abstract_Interface_Alias (Prim))
+ if Present (Interface_Alias (Prim))
and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then
Prim_Pos := DT_Position (Alias (Prim));
-- Collect the components associated with secondary dispatch tables
- if Has_Abstract_Interfaces (Typ) then
+ if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
end if;
-- 2) Generate the secondary tag entities
- if Has_Abstract_Interfaces (Typ) then
+ if Has_Interfaces (Typ) then
Suffix_Index := 0;
-- For each interface type we build an unique external name
return;
end if;
- if not Present (Abstract_Interface_Alias (Prim)) then
+ if not Present (Interface_Alias (Prim)) then
Tag_Typ := Scope (DTC_Entity (Prim));
Pos := DT_Position (Prim);
Tag := First_Tag_Component (Tag_Typ);
else
Tag_Typ := Find_Dispatching_Type (Alias (Prim));
- Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
+ Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
pragma Assert (Is_Interface (Iface_Typ));
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
- if not Is_Parent (Iface_Typ, Tag_Typ)
+ if not Is_Ancestor (Iface_Typ, Tag_Typ)
and then Present (Thunk_Code)
then
-- Comment needed on why checks are suppressed. This is not just
Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (Has_Thunks (Iface_DT_Ptr));
- Iface_Prim := Abstract_Interface_Alias (Prim);
+ Iface_Prim := Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ);
L := New_List;
-- Primitive operations covering abstract interfaces are
-- allocated later
- elsif Present (Abstract_Interface_Alias (Op)) then
+ elsif Present (Interface_Alias (Op)) then
null;
-- Predefined dispatching operations are completely safe. They
-- Start of processing for Set_All_DT_Position
begin
+ pragma Assert (Present (First_Tag_Component (Typ)));
+
-- Set the DT_Position for each primitive operation. Perform some
-- sanity checks to avoid to build completely inconsistent dispatch
-- tables.
-- Overriding primitives of ancestor abstract interfaces
- elsif Present (Abstract_Interface_Alias (Prim))
- and then Is_Parent
- (Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim)),
- Typ)
+ elsif Present (Interface_Alias (Prim))
+ and then Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
then
pragma Assert (DT_Position (Prim) = No_Uint
- and then Present (DTC_Entity
- (Abstract_Interface_Alias (Prim))));
+ and then Present (DTC_Entity (Interface_Alias (Prim))));
- E := Abstract_Interface_Alias (Prim);
+ E := Interface_Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
pragma Assert
-- Overriding primitives must use the same entry as the
-- overridden primitive.
- elsif not Present (Abstract_Interface_Alias (Prim))
+ elsif not Present (Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
- and then Is_Parent
+ and then Is_Ancestor
(Find_Dispatching_Type (Alias (Prim)), Typ)
and then Present (DTC_Entity (Alias (Prim)))
then
-- Primitives covering interface primitives are handled later
- elsif Present (Abstract_Interface_Alias (Prim)) then
+ elsif Present (Interface_Alias (Prim)) then
null;
else
Prim := Node (Prim_Elmt);
if DT_Position (Prim) = No_Uint
- and then Present (Abstract_Interface_Alias (Prim))
+ and then Present (Interface_Alias (Prim))
then
pragma Assert (Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-- Check if this entry will be placed in the primary DT
- if Is_Parent (Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim)),
- Typ)
+ if Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
else
pragma Assert
- (DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
+ (DT_Position (Interface_Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim,
- DT_Position (Abstract_Interface_Alias (Prim)));
+ DT_Position (Interface_Alias (Prim)));
end if;
end if;
-- point of declaration, but for inherited operations it must
-- be done when building the dispatch table.
- -- Ada 2005 (AI-251): Hidden entities associated with abstract
- -- interface primitives are not taken into account because the
- -- check is done with the aliased primitive.
+ -- Ada 2005 (AI-251): Primitives associated with interfaces are
+ -- excluded from this check because interfaces must be visible in
+ -- the public and private part (RM 7.3 (7.3/2))
if Is_Abstract_Type (Typ)
and then Is_Abstract_Subprogram (Prim)
and then Present (Alias (Prim))
- and then not Present (Abstract_Interface_Alias (Prim))
+ and then not Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Prim)))
+ and then not Present (Interface_Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
and then
Prim : Entity_Id)
is
begin
- if Present (Abstract_Interface_Alias (Prim))
+ if Present (Interface_Alias (Prim))
and then Is_Interface
- (Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim)))
+ (Find_Dispatching_Type (Interface_Alias (Prim)))
then
Set_DTC_Entity (Prim,
Find_Interface_Tag
(T => Tagged_Type,
- Iface => Find_Dispatching_Type
- (Abstract_Interface_Alias (Prim))));
+ Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
else
Set_DTC_Entity (Prim,
First_Tag_Component (Tagged_Type));
Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
end if;
- if Present (Abstract_Interface_Alias (Prim)) then
+ if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
- Write_Name (Chars (Scope (DTC_Entity
- (Abstract_Interface_Alias (Prim)))));
+ Write_Name
+ (Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');
- Write_Int (Int (Abstract_Interface_Alias (Prim)));
+ Write_Int (Int (Interface_Alias (Prim)));
end if;
Write_Str (")");
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Otherwise they are set to the defining identifier and the subprogram
-- body of the generated thunk.
+ function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
+ -- required to implement interfaces.
+
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-- If the result type is not parent of Tag_Arg then we need to
-- locate the tag of the secondary dispatch table.
- if not Is_Parent (Etype (Result_Typ), Etype (Tag_Arg)) then
+ if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
Iface_Tag :=
(T : Entity_Id;
Iface : Entity_Id) return Elmt_Id
is
- ADT : Elmt_Id;
- Found : Boolean := False;
- Typ : Entity_Id := T;
-
- procedure Find_Secondary_Table (Typ : Entity_Id);
- -- Internal subprogram used to recursively climb to the ancestors
-
- --------------------------
- -- Find_Secondary_Table --
- --------------------------
-
- procedure Find_Secondary_Table (Typ : Entity_Id) is
- AI_Elmt : Elmt_Id;
- AI : Node_Id;
-
- begin
- pragma Assert (Typ /= Iface);
-
- -- Climb to the ancestor (if any) handling synchronized interface
- -- derivations and private types
-
- if Is_Concurrent_Record_Type (Typ) then
- declare
- Iface_List : constant List_Id := Abstract_Interface_List (Typ);
-
- begin
- if Is_Non_Empty_List (Iface_List) then
- Find_Secondary_Table (Etype (First (Iface_List)));
- end if;
- end;
-
- elsif Present (Full_View (Etype (Typ))) then
- if Full_View (Etype (Typ)) /= Typ then
- Find_Secondary_Table (Full_View (Etype (Typ)));
- end if;
-
- elsif Etype (Typ) /= Typ then
- Find_Secondary_Table (Etype (Typ));
- end if;
-
- -- Traverse the list of interfaces implemented by the type
-
- if not Found
- and then Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
- then
- AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
- while Present (AI_Elmt) loop
- AI := Node (AI_Elmt);
-
- if AI = Iface or else Is_Ancestor (Iface, AI) then
- Found := True;
- return;
- end if;
-
- -- Document what is going on here, why four Next's???
-
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (AI_Elmt);
- end loop;
- end if;
- end Find_Secondary_Table;
-
- -- Start of processing for Find_Interface_ADT
+ ADT : Elmt_Id;
+ Typ : Entity_Id := T;
begin
pragma Assert (Is_Interface (Iface));
(not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type);
- ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
- pragma Assert (Present (Node (ADT)));
- Find_Secondary_Table (Typ);
- pragma Assert (Found);
- return ADT;
+ if Is_Ancestor (Iface, Typ) then
+ return First_Elmt (Access_Disp_Table (Typ));
+
+ else
+ ADT :=
+ Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
+ while Present (ADT)
+ and then Present (Related_Type (Node (ADT)))
+ and then Related_Type (Node (ADT)) /= Iface
+ and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
+ loop
+ Next_Elmt (ADT);
+ end loop;
+
+ pragma Assert (Present (Related_Type (Node (ADT))));
+ return ADT;
+ end if;
end Find_Interface_ADT;
------------------------
Found : Boolean := False;
Typ : Entity_Id := T;
- Is_Primary_Tag : Boolean := False;
-
- Is_Sync_Typ : Boolean := False;
- -- In case of non concurrent-record-types each parent-type has the
- -- tags associated with the interface types that are not implemented
- -- by the ancestors; concurrent-record-types have their whole list of
- -- interface tags (and this case requires some special management).
-
procedure Find_Tag (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
-- therefore shares the main tag.
if Typ = Iface then
- if Is_Sync_Typ then
- Is_Primary_Tag := True;
- else
- pragma Assert
- (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
- AI_Tag := First_Tag_Component (Typ);
- end if;
-
+ pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := First_Tag_Component (Typ);
Found := True;
return;
end if;
- -- Handle synchronized interface derivations
-
- if Is_Concurrent_Record_Type (Typ) then
- declare
- Iface_List : constant List_Id := Abstract_Interface_List (Typ);
- begin
- if Is_Non_Empty_List (Iface_List) then
- Find_Tag (Etype (First (Iface_List)));
- end if;
- end;
-
-- Climb to the root type handling private types
- elsif Present (Full_View (Etype (Typ))) then
+ if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Tag (Full_View (Etype (Typ)));
end if;
-- Traverse the list of interfaces implemented by the type
if not Found
- and then Present (Abstract_Interfaces (Typ))
- and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ and then Present (Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
then
-- Skip the tag associated with the primary table
- if not Is_Sync_Typ then
- pragma Assert
- (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
- AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
- pragma Assert (Present (AI_Tag));
- end if;
+ pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
- AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ AI_Elmt := First_Elmt (Interfaces (Typ));
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
Typ := Non_Limited_View (Typ);
end if;
- if not Is_Concurrent_Record_Type (Typ) then
- Find_Tag (Typ);
- pragma Assert (Found);
- return AI_Tag;
-
- -- Concurrent record types
-
- else
- Is_Sync_Typ := True;
- AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
- Find_Tag (Typ);
- pragma Assert (Found);
-
- if Is_Primary_Tag then
- return First_Tag_Component (Typ);
- else
- return AI_Tag;
- end if;
- end if;
- end Find_Interface_Tag;
-
- --------------------
- -- Find_Interface --
- --------------------
-
- function Find_Interface
- (T : Entity_Id;
- Comp : Entity_Id) return Entity_Id
- is
- AI_Tag : Entity_Id;
- Found : Boolean := False;
- Iface : Entity_Id;
- Typ : Entity_Id := T;
-
- Is_Sync_Typ : Boolean := False;
- -- In case of non concurrent-record-types each parent-type has the
- -- tags associated with the interface types that are not implemented
- -- by the ancestors; concurrent-record-types have their whole list of
- -- interface tags (and this case requires some special management).
-
- procedure Find_Iface (Typ : Entity_Id);
- -- Internal subprogram used to recursively climb to the ancestors
-
- ----------------
- -- Find_Iface --
- ----------------
-
- procedure Find_Iface (Typ : Entity_Id) is
- AI_Elmt : Elmt_Id;
-
- begin
- -- Climb to the root type
-
- -- Handle synchronized interface derivations
-
- if Is_Concurrent_Record_Type (Typ) then
- declare
- Iface_List : constant List_Id := Abstract_Interface_List (Typ);
- begin
- if Is_Non_Empty_List (Iface_List) then
- Find_Iface (Etype (First (Iface_List)));
- end if;
- end;
-
- -- Handle the common case
-
- elsif Etype (Typ) /= Typ then
- pragma Assert (not Present (Full_View (Etype (Typ))));
- Find_Iface (Etype (Typ));
- end if;
-
- -- Traverse the list of interfaces implemented by the type
-
- if not Found
- and then Present (Abstract_Interfaces (Typ))
- and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
- then
- -- Skip the tag associated with the primary table
-
- if not Is_Sync_Typ then
- pragma Assert
- (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
- AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
- pragma Assert (Present (AI_Tag));
- end if;
-
- AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
- while Present (AI_Elmt) loop
- if AI_Tag = Comp then
- Iface := Node (AI_Elmt);
- Found := True;
- return;
- end if;
-
- AI_Tag := Next_Tag_Component (AI_Tag);
- Next_Elmt (AI_Elmt);
- end loop;
- end if;
- end Find_Iface;
-
- -- Start of processing for Find_Interface
-
- begin
- -- Handle private types
-
- if Has_Private_Declaration (Typ)
- and then Present (Full_View (Typ))
- then
- Typ := Full_View (Typ);
- end if;
-
- -- Handle access types
-
- if Is_Access_Type (Typ) then
- Typ := Directly_Designated_Type (Typ);
- end if;
-
- -- Handle task and protected types implementing interfaces
-
- if Is_Concurrent_Type (Typ) then
- Typ := Corresponding_Record_Type (Typ);
- end if;
-
- if Is_Class_Wide_Type (Typ) then
- Typ := Etype (Typ);
- end if;
-
- -- Handle entities from the limited view
-
- if Ekind (Typ) = E_Incomplete_Type then
- pragma Assert (Present (Non_Limited_View (Typ)));
- Typ := Non_Limited_View (Typ);
- end if;
-
- if Is_Concurrent_Record_Type (Typ) then
- Is_Sync_Typ := True;
- AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
- end if;
-
- Find_Iface (Typ);
+ Find_Tag (Typ);
pragma Assert (Found);
- return Iface;
- end Find_Interface;
+ return AI_Tag;
+ end Find_Interface_Tag;
------------------
-- Find_Prim_Op --
and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type;
- -----------------------------------------
- -- Is_Predefined_Dispatching_Operation --
- -----------------------------------------
-
- function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
- .. Name_Len));
- if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
- or else TSS_Name = TSS_Stream_Read
- or else TSS_Name = TSS_Stream_Write
- or else TSS_Name = TSS_Stream_Input
- or else TSS_Name = TSS_Stream_Output
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
- or else Chars (E) = Name_uAssign
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else (Ada_Version >= Ada_05
- and then (Chars (E) = Name_uDisp_Asynchronous_Select
- or else Chars (E) = Name_uDisp_Conditional_Select
- or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
- or else Chars (E) = Name_uDisp_Get_Task_Id
- or else Chars (E) = Name_uDisp_Requeue
- or else Chars (E) = Name_uDisp_Timed_Select))
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Dispatching_Operation;
-
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
-- declarations and/or allocations when the type is indefinite (including
-- class-wide).
- function Find_Interface
- (T : Entity_Id;
- Comp : Entity_Id) return Entity_Id;
- -- Ada 2005 (AI-251): Given a tagged type and one of its components
- -- associated with the secondary dispatch table of an abstract interface
- -- type, return the associated abstract interface type.
-
function Find_Interface_ADT
(T : Entity_Id;
Iface : Entity_Id) return Elmt_Id;
-- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables.
- function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
-
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
-- Determine whether the node P is a reference to a bit packed array, i.e.
-- whether the designated object is a component of a bit packed array, or a
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
New_Entry (Tref);
if Is_Record_Type (Ent)
- and then Present (Abstract_Interfaces (Ent))
+ and then Present (Interfaces (Ent))
then
-- Add an entry for each one of the given interfaces
-- implemented by type Ent.
declare
- Elmt : Elmt_Id;
-
+ Elmt : Elmt_Id := First_Elmt (Interfaces (Ent));
begin
- Elmt := First_Elmt (Abstract_Interfaces (Ent));
while Present (Elmt) loop
New_Entry (Node (Elmt));
Next_Elmt (Elmt);
-- Additional information for types with progenitors
if Is_Record_Type (XE.Ent)
- and then Present (Abstract_Interfaces (XE.Ent))
+ and then Present (Interfaces (XE.Ent))
then
declare
- Elmt : Elmt_Id;
-
+ Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
begin
- Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
while Present (Elmt) loop
Check_Type_Reference (Node (Elmt), True);
Next_Elmt (Elmt);
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Exp_Util; use Exp_Util;
+with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Lib; use Lib;
with Namet; use Namet;
-- Now verify that the actual includes all other ancestors of
-- the formal.
- Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T));
+ Elmt := First_Elmt (Interfaces (A_Gen_T));
while Present (Elmt) loop
if not Interface_Present_In_Ancestor
(Act_T, Get_Instance_Of (Node (Elmt)))
function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
is
- Interfaces : Elist_Id;
Intfc_Elmt : Elmt_Id;
begin
-- progenitors.
else
- Interfaces := Abstract_Interfaces (T2);
-
- Intfc_Elmt := First_Elmt (Interfaces);
+ Intfc_Elmt := First_Elmt (Interfaces (T2));
while Present (Intfc_Elmt) loop
if Is_Ancestor (T1, Node (Intfc_Elmt)) then
return True;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
+with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-- view cannot itself have a full view (it would get clobbered during
-- view exchanges).
- procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id);
- -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
-
procedure Check_Access_Discriminant_Requires_Limited
(D : Node_Id;
Loc : Node_Id);
-- Validate the initialization of an object declaration. T is the required
-- type, and Exp is the initialization expression.
+ procedure Check_Interfaces (N : Node_Id; Def : Node_Id);
+ -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
+
procedure Check_Or_Process_Discriminants
(N : Node_Id;
T : Entity_Id;
-- appropriate semantic fields. If the full view of the parent is a record
-- type, build constrained components of subtype.
- procedure Derive_Interface_Subprograms
+ procedure Derive_Progenitor_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.
+ Tagged_Type : Entity_Id);
+ -- Ada 2005 (AI-251): To complete type derivation, collect the primitive
+ -- operations of progenitors of Tagged_Type, and replace the subsidiary
+ -- subtypes with Tagged_Type, to build the specs of the inherited interface
+ -- primitives. The derived primitives are aliased to those of the
+ -- interface. This routine takes care also of transferring to the full-view
+ -- subprograms associated with the partial-view of Tagged_Type that cover
+ -- interface primitives.
procedure Derived_Standard_Character
(N : Node_Id;
procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Elmt : Elmt_Id;
- Ext : Node_Id;
L : List_Id;
Last_Tag : Node_Id;
- Comp : Node_Id;
-
- procedure Add_Sync_Iface_Tags (T : Entity_Id);
- -- Local subprogram used to recursively climb through the parents
- -- of T to add the tags of all the progenitor interfaces.
procedure Add_Tag (Iface : Entity_Id);
-- Add tag for one of the progenitor interfaces
- -------------------------
- -- Add_Sync_Iface_Tags --
- -------------------------
-
- procedure Add_Sync_Iface_Tags (T : Entity_Id) is
- begin
- if Etype (T) /= T then
- Add_Sync_Iface_Tags (Etype (T));
- end if;
-
- Elmt := First_Elmt (Abstract_Interfaces (T));
- while Present (Elmt) loop
- Add_Tag (Node (Elmt));
- Next_Elmt (Elmt);
- end loop;
- end Add_Sync_Iface_Tags;
-
-------------
-- Add_Tag --
-------------
-- Local variables
- Iface_List : List_Id;
+ Elmt : Elmt_Id;
+ Ext : Node_Id;
+ Comp : Node_Id;
-- Start of processing for Add_Interface_Tag_Components
or else (Is_Concurrent_Record_Type (Typ)
and then Is_Empty_List (Abstract_Interface_List (Typ)))
or else (not Is_Concurrent_Record_Type (Typ)
- and then No (Abstract_Interfaces (Typ))
- and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ and then No (Interfaces (Typ))
+ and then Is_Empty_Elmt_List (Interfaces (Typ)))
then
return;
end if;
-- corresponding with all the interfaces that are not implemented
-- by the parent.
- if Is_Concurrent_Record_Type (Typ) then
- Iface_List := Abstract_Interface_List (Typ);
-
- if Is_Non_Empty_List (Iface_List) then
- Add_Sync_Iface_Tags (Etype (First (Iface_List)));
- end if;
- end if;
-
- if Present (Abstract_Interfaces (Typ)) then
- Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ if Present (Interfaces (Typ)) then
+ Elmt := First_Elmt (Interfaces (Typ));
while Present (Elmt) loop
Add_Tag (Node (Elmt));
Next_Elmt (Elmt);
CW : constant Entity_Id := Class_Wide_Type (T);
begin
- Set_Is_Tagged_Type (T);
+ 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));
+ Set_Is_Limited_Record (T, Limited_Present (Def)
+ or else Task_Present (Def)
+ or else Protected_Present (Def)
+ or else Synchronized_Present (Def));
-- Type is abstract if full declaration carries keyword, or if previous
-- partial view did.
Set_Is_Abstract_Type (T);
- Set_Is_Interface (T);
+ Set_Is_Interface (T);
-- Type is a limited interface if it includes the keyword limited, task,
-- protected, or synchronized.
or else Synchronized_Present (Def)
or else Task_Present (Def));
- Set_Is_Protected_Interface (T, Protected_Present (Def));
- Set_Is_Task_Interface (T, Task_Present (Def));
+ Set_Is_Protected_Interface (T, Protected_Present (Def));
+ Set_Is_Task_Interface (T, Task_Present (Def));
-- Type is a synchronized interface if it includes the keyword task,
-- protected, or synchronized.
or else Protected_Present (Def)
or else Task_Present (Def));
- Set_Abstract_Interfaces (T, New_Elmt_List);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Interfaces (T, New_Elmt_List);
+ Set_Primitive_Operations (T, New_Elmt_List);
-- Complete the decoration of the class-wide entity if it was already
-- built (i.e. during the creation of the limited view)
-- The progenitors (if any) must be limited or synchronized
-- interfaces.
- if Present (Abstract_Interfaces (T)) then
+ if Present (Interfaces (T)) then
declare
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
begin
- Iface_Elmt := First_Elmt (Abstract_Interfaces (T));
+ Iface_Elmt := First_Elmt (Interfaces (T));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
Analyze_Interface_Declaration (Derived_Type, Type_Def);
end if;
- Set_Abstract_Interfaces (Derived_Type, No_Elist);
+ Set_Interfaces (Derived_Type, No_Elist);
end if;
-- Fields inherited from the Parent_Type
if Is_Record_Type (Derived_Type) then
Set_OK_To_Reorder_Components
- (Derived_Type, OK_To_Reorder_Components (Parent_Base));
+ (Derived_Type, OK_To_Reorder_Components (Parent_Base));
Set_Reverse_Bit_Order
- (Derived_Type, Reverse_Bit_Order (Parent_Base));
+ (Derived_Type, Reverse_Bit_Order (Parent_Base));
end if;
-- Direct controlled types do not inherit Finalize_Storage_Only flag
-- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
- Check_Abstract_Interfaces (N, Type_Def);
+ Check_Interfaces (N, Type_Def);
-- Ada 2005 (AI-251): Collect the list of progenitors that are
-- not already in the parents.
- Collect_Abstract_Interfaces
- (T => Derived_Type,
- Ifaces_List => Ifaces_List,
- Exclude_Parent_Interfaces => True);
- Set_Abstract_Interfaces (Derived_Type, Ifaces_List);
+ Collect_Interfaces
+ (T => Derived_Type,
+ Ifaces_List => Ifaces_List,
+ Exclude_Parents => True);
+
+ Set_Interfaces (Derived_Type, Ifaces_List);
end;
end if;
-- implemented interfaces if we are in expansion mode
if Expander_Active
- and then Has_Abstract_Interfaces (Derived_Type)
+ and then Has_Interfaces (Derived_Type)
then
Add_Interface_Tag_Components (N, Derived_Type);
end if;
Set_Underlying_Full_View (Typ, Full_View (Subt));
end Build_Underlying_Full_View;
- -------------------------------
- -- Check_Abstract_Interfaces --
- -------------------------------
-
- procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is
- Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
-
- Iface : Node_Id;
- Iface_Def : Node_Id;
- Iface_Typ : Entity_Id;
- Parent_Node : Node_Id;
-
- Is_Task : Boolean := False;
- -- Set True if parent type or any progenitor is a task interface
-
- Is_Protected : Boolean := False;
- -- Set True if parent type or any progenitor is a protected interface
-
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
- -- Check that a progenitor is compatible with declaration.
- -- Error is posted on Error_Node.
-
- ------------------
- -- Check_Ifaces --
- ------------------
-
- procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
- Iface_Id : constant Entity_Id :=
- Defining_Identifier (Parent (Iface_Def));
- Type_Def : Node_Id;
-
- begin
- if Nkind (N) = N_Private_Extension_Declaration then
- Type_Def := N;
- else
- Type_Def := Type_Definition (N);
- end if;
-
- if Is_Task_Interface (Iface_Id) then
- Is_Task := True;
-
- elsif Is_Protected_Interface (Iface_Id) then
- Is_Protected := True;
- end if;
-
- -- Check that the characteristics of the progenitor are compatible
- -- with the explicit qualifier in the declaration.
- -- The check only applies to qualifiers that come from source.
- -- Limited_Present also appears in the declaration of corresponding
- -- records, and the check does not apply to them.
-
- if Limited_Present (Type_Def)
- and then not
- Is_Concurrent_Record_Type (Defining_Identifier (N))
- then
- if Is_Limited_Interface (Parent_Type)
- and then not Is_Limited_Interface (Iface_Id)
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
-
- elsif
- (Task_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def))
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_NE
- ("progenitor& must be limited interface",
- Error_Node, Iface_Id);
- end if;
-
- -- Protected interfaces can only inherit from limited, synchronized
- -- or protected interfaces.
-
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Protected_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Protected_Present (Iface_Def)
- then
- null;
-
- elsif Task_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from task interface", Error_Node);
-
- else
- Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
-
- -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
- -- limited and synchronized.
-
- elsif Synchronized_Present (Type_Def) then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- then
- null;
-
- elsif Protected_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from protected interface", Error_Node);
-
- elsif Task_Present (Iface_Def)
- and then Nkind (N) /= N_Private_Extension_Declaration
- then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from task interface", Error_Node);
-
- elsif not Is_Limited_Interface (Iface_Id) then
- Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
- & " from non-limited interface", Error_Node);
- end if;
-
- -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
- -- synchronized or task interfaces.
-
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Task_Present (Type_Def)
- then
- if Limited_Present (Iface_Def)
- or else Synchronized_Present (Iface_Def)
- or else Task_Present (Iface_Def)
- then
- null;
-
- elsif Protected_Present (Iface_Def) then
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " protected interface", Error_Node);
-
- else
- Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
- & " non-limited interface", Error_Node);
- end if;
- end if;
- end Check_Ifaces;
-
- -- Start of processing for Check_Abstract_Interfaces
-
- begin
- if Is_Interface (Parent_Type) then
- if Is_Task_Interface (Parent_Type) then
- Is_Task := True;
-
- elsif Is_Protected_Interface (Parent_Type) then
- Is_Protected := True;
- end if;
- end if;
-
- if Nkind (N) = N_Private_Extension_Declaration then
-
- -- Check that progenitors are compatible with declaration
-
- Iface := First (Interface_List (Def));
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
-
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
-
- if not Is_Interface (Iface_Typ) then
- Error_Msg_NE ("(Ada 2005) & must be an interface",
- Iface, Iface_Typ);
-
- else
- Check_Ifaces (Iface_Def, Iface);
- end if;
-
- Next (Iface);
- end loop;
-
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
-
- return;
- end if;
-
- -- Full type declaration of derived type.
- -- Check compatibility with parent if it is interface type
-
- if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
- and then Is_Interface (Parent_Type)
- then
- Parent_Node := Parent (Parent_Type);
-
- -- More detailed checks for interface varieties
-
- Check_Ifaces
- (Iface_Def => Type_Definition (Parent_Node),
- Error_Node => Subtype_Indication (Type_Definition (N)));
- end if;
-
- Iface := First (Interface_List (Def));
-
- while Present (Iface) loop
- Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
-
- Parent_Node := Parent (Base_Type (Iface_Typ));
- Iface_Def := Type_Definition (Parent_Node);
-
- if not Is_Interface (Iface_Typ) then
- Error_Msg_NE ("(Ada 2005) & must be an interface",
- Iface, Iface_Typ);
-
- else
- -- "The declaration of a specific descendant of an interface
- -- type freezes the interface type" RM 13.14
-
- Freeze_Before (N, Iface_Typ);
- Check_Ifaces (Iface_Def, Error_Node => Iface);
- end if;
-
- Next (Iface);
- end loop;
-
- if Is_Task and Is_Protected then
- Error_Msg_N
- ("type cannot derive from task and protected interface", N);
- end if;
-
- end Check_Abstract_Interfaces;
-
-------------------------------
-- Check_Abstract_Overriding --
-------------------------------
if Is_Null_Extension (T)
and then Has_Controlling_Result (Subp)
and then Ada_Version >= Ada_05
- and then Present (Alias (Subp))
+ and then Present (Alias_Subp)
and then not Comes_From_Source (Subp)
- and then not Is_Abstract_Subprogram (Alias (Subp))
+ and then not Is_Abstract_Subprogram (Alias_Subp)
and then not Is_Access_Type (Etype (Subp))
then
null;
+ -- Ada 2005 (AI-251): Internal entities of interfaces need no
+ -- processing because this check is done with the aliased
+ -- entity
+
+ elsif Present (Interface_Alias (Subp)) then
+ null;
+
elsif (Is_Abstract_Subprogram (Subp)
or else Requires_Overriding (Subp)
or else
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract_Type (T)
and then Convention (T) /= Convention_CIL
- 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_Requeue
- and then Chars (Subp) /= Name_uDisp_Timed_Select
+ and then not Is_Predefined_Interface_Primitive (Subp)
-- 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))
+ and then not Present (Interface_Alias (Subp))
then
if Present (Alias_Subp) then
or else Requires_Overriding (Subp)
or else Is_Access_Type (Etype (Subp)))
then
- -- The body of predefined primitives of tagged types derived
- -- from interface types are generated later by Freeze_Type.
-
- if Is_Predefined_Dispatching_Operation (Subp)
- and then Is_Abstract_Subprogram (Alias_Subp)
- and then Is_Interface
- (Root_Type (Find_Dispatching_Type (Subp)))
+ -- Avoid reporting error in case of abstract predefined
+ -- primitive inherited from interface type because the
+ -- body of internally generated predefined primitives
+ -- of tagged types are generated later by Freeze_Type
+
+ if Is_Interface (Root_Type (T))
+ and then Is_Abstract_Subprogram (Subp)
+ and then Is_Predefined_Dispatching_Operation (Subp)
+ and then not Comes_From_Source (Ultimate_Alias (Subp))
then
null;
-- abstract interfaces.
elsif Is_Concurrent_Record_Type (T)
- and then Present (Abstract_Interfaces (T))
+ and then Present (Interfaces (T))
then
-- The controlling formal of Subp must be of mode "out",
-- "in out" or an access-to-variable to be overridden.
-- in -gnatj mode) ???
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);
- Error_Msg_N
- ("\to be overridden by protected procedure or " &
- "entry (RM 9.4(11.9/2))", T);
+ if not Is_Predefined_Dispatching_Operation (Subp) then
+ Error_Msg_NE
+ ("first formal of & must be of mode `OUT`, " &
+ "`IN OUT` or access-to-variable", T, Subp);
+ Error_Msg_N
+ ("\to be overridden by protected procedure or " &
+ "entry (RM 9.4(11.9/2))", T);
+ end if;
-- Some other kind of overriding failure
if Ada_Version >= Ada_05
and then Is_Hidden (Subp)
- and then Present (Abstract_Interface_Alias (Subp))
- and then Implemented_By_Entry (Abstract_Interface_Alias (Subp))
+ and then Present (Interface_Alias (Subp))
+ and then Implemented_By_Entry (Interface_Alias (Subp))
and then Present (Alias_Subp)
and then
(not Is_Primitive_Wrapper (Alias_Subp)
Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
end if;
- Error_Msg_Node_2 := Abstract_Interface_Alias (Subp);
+ Error_Msg_Node_2 := Interface_Alias (Subp);
Error_Msg_NE
("type & must implement abstract subprogram & with an entry",
Error_Ent, Error_Ent);
end if;
end Check_Initialization;
+ ----------------------
+ -- Check_Interfaces --
+ ----------------------
+
+ procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is
+ Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N));
+
+ Iface : Node_Id;
+ Iface_Def : Node_Id;
+ Iface_Typ : Entity_Id;
+ Parent_Node : Node_Id;
+
+ Is_Task : Boolean := False;
+ -- Set True if parent type or any progenitor is a task interface
+
+ Is_Protected : Boolean := False;
+ -- Set True if parent type or any progenitor is a protected interface
+
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
+ -- Check that a progenitor is compatible with declaration.
+ -- Error is posted on Error_Node.
+
+ ------------------
+ -- Check_Ifaces --
+ ------------------
+
+ procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
+ Iface_Id : constant Entity_Id :=
+ Defining_Identifier (Parent (Iface_Def));
+ Type_Def : Node_Id;
+
+ begin
+ if Nkind (N) = N_Private_Extension_Declaration then
+ Type_Def := N;
+ else
+ Type_Def := Type_Definition (N);
+ end if;
+
+ if Is_Task_Interface (Iface_Id) then
+ Is_Task := True;
+
+ elsif Is_Protected_Interface (Iface_Id) then
+ Is_Protected := True;
+ end if;
+
+ -- Check that the characteristics of the progenitor are compatible
+ -- with the explicit qualifier in the declaration.
+ -- The check only applies to qualifiers that come from source.
+ -- Limited_Present also appears in the declaration of corresponding
+ -- records, and the check does not apply to them.
+
+ if Limited_Present (Type_Def)
+ and then not
+ Is_Concurrent_Record_Type (Defining_Identifier (N))
+ then
+ if Is_Limited_Interface (Parent_Type)
+ and then not Is_Limited_Interface (Iface_Id)
+ then
+ Error_Msg_NE
+ ("progenitor& must be limited interface",
+ Error_Node, Iface_Id);
+
+ elsif
+ (Task_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def))
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_NE
+ ("progenitor& must be limited interface",
+ Error_Node, Iface_Id);
+ end if;
+
+ -- Protected interfaces can only inherit from limited, synchronized
+ -- or protected interfaces.
+
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Protected_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Protected_Present (Iface_Def)
+ then
+ null;
+
+ elsif Task_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
+ & " from task interface", Error_Node);
+
+ else
+ Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
+ & " from non-limited interface", Error_Node);
+ end if;
+
+ -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
+ -- limited and synchronized.
+
+ elsif Synchronized_Present (Type_Def) then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ then
+ null;
+
+ elsif Protected_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
+ & " from protected interface", Error_Node);
+
+ elsif Task_Present (Iface_Def)
+ and then Nkind (N) /= N_Private_Extension_Declaration
+ then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
+ & " from task interface", Error_Node);
+
+ elsif not Is_Limited_Interface (Iface_Id) then
+ Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
+ & " from non-limited interface", Error_Node);
+ end if;
+
+ -- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
+ -- synchronized or task interfaces.
+
+ elsif Nkind (N) = N_Full_Type_Declaration
+ and then Task_Present (Type_Def)
+ then
+ if Limited_Present (Iface_Def)
+ or else Synchronized_Present (Iface_Def)
+ or else Task_Present (Iface_Def)
+ then
+ null;
+
+ elsif Protected_Present (Iface_Def) then
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
+ & " protected interface", Error_Node);
+
+ else
+ Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
+ & " non-limited interface", Error_Node);
+ end if;
+ end if;
+ end Check_Ifaces;
+
+ -- Start of processing for Check_Interfaces
+
+ begin
+ if Is_Interface (Parent_Type) then
+ if Is_Task_Interface (Parent_Type) then
+ Is_Task := True;
+
+ elsif Is_Protected_Interface (Parent_Type) then
+ Is_Protected := True;
+ end if;
+ end if;
+
+ if Nkind (N) = N_Private_Extension_Declaration then
+
+ -- Check that progenitors are compatible with declaration
+
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Iface, Iface_Typ);
+
+ else
+ Check_Ifaces (Iface_Def, Iface);
+ end if;
+
+ Next (Iface);
+ end loop;
+
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
+ end if;
+
+ return;
+ end if;
+
+ -- Full type declaration of derived type.
+ -- Check compatibility with parent if it is interface type
+
+ if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
+ and then Is_Interface (Parent_Type)
+ then
+ Parent_Node := Parent (Parent_Type);
+
+ -- More detailed checks for interface varieties
+
+ Check_Ifaces
+ (Iface_Def => Type_Definition (Parent_Node),
+ Error_Node => Subtype_Indication (Type_Definition (N)));
+ end if;
+
+ Iface := First (Interface_List (Def));
+ while Present (Iface) loop
+ Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
+
+ Parent_Node := Parent (Base_Type (Iface_Typ));
+ Iface_Def := Type_Definition (Parent_Node);
+
+ if not Is_Interface (Iface_Typ) then
+ Error_Msg_NE ("(Ada 2005) & must be an interface",
+ Iface, Iface_Typ);
+
+ else
+ -- "The declaration of a specific descendant of an interface
+ -- type freezes the interface type" RM 13.14
+
+ Freeze_Before (N, Iface_Typ);
+ Check_Ifaces (Iface_Def, Error_Node => Iface);
+ end if;
+
+ Next (Iface);
+ end loop;
+
+ if Is_Task and Is_Protected then
+ Error_Msg_N
+ ("type cannot derive from task and protected interface", N);
+ end if;
+ end Check_Interfaces;
+
------------------------------------
-- Check_Or_Process_Discriminants --
------------------------------------
Scale_Val : Uint;
Bound_Val : Ureal;
- -- Start of processing for Decimal_Fixed_Point_Type_Declaration
-
begin
Check_Restriction (No_Fixed_Point, Def);
Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
- ----------------------------------
- -- Derive_Interface_Subprograms --
- ----------------------------------
+ -----------------------------------
+ -- Derive_Progenitor_Subprograms --
+ -----------------------------------
- procedure Derive_Interface_Subprograms
+ procedure Derive_Progenitor_Subprograms
(Parent_Type : Entity_Id;
- Tagged_Type : Entity_Id;
- Ifaces_List : Elist_Id)
+ Tagged_Type : Entity_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.
-
- function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean;
- -- Determine if Subp already in the list L
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Subp : Entity_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Typ : Entity_Id;
- procedure Remove_Homonym (E : Entity_Id);
- -- Removes E from the homonym chain
+ begin
+ pragma Assert (Ada_Version >= Ada_05
+ and then Is_Record_Type (Tagged_Type)
+ and then Is_Tagged_Type (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type));
+
+ -- Step 1: Transfer to the full-view primitives asociated with the
+ -- partial-view that cover interface primitives. Conceptually this
+ -- work should be done later by Process_Full_View; done here to
+ -- simplify its implementation at later stages. It can be safely
+ -- done here because interfaces must be visible in the partial and
+ -- private view (RM 7.3(7.3/2)).
+
+ -- Small optimization: This work is only required if the parent is
+ -- abstract. If the tagged type is not abstract, it cannot have
+ -- abstract primitives (the only entities in the list of primitives of
+ -- non-abstract tagged types that can reference abstract primitives
+ -- through its Alias attribute are the internal entities that have
+ -- attribute Interface_Alias, and these entities are generated later
+ -- by Freeze_Record_Type).
- ----------------------------------
- -- Collect_Interface_Primitives --
- ----------------------------------
+ if In_Private_Part (Current_Scope)
+ and then Is_Abstract_Type (Parent_Type)
+ then
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- 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;
+ -- At this stage it is not possible to have entities in the list
+ -- of primitives that have attribute Interface_Alias
- begin
- pragma Assert (Is_Tagged_Type (Tagged_Type)
- and then Has_Abstract_Interfaces (Tagged_Type));
+ pragma Assert (No (Interface_Alias (Subp)));
- Collect_Abstract_Interfaces (Tagged_Type, Ifaces_List);
+ Typ := Find_Dispatching_Type (Ultimate_Alias (Subp));
- 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 Is_Interface (Typ) then
+ E := Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Subp);
- if not Is_Predefined_Dispatching_Operation (Prim) then
- Append_Elmt (Prim, Op_List);
+ if Present (E)
+ and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ
+ then
+ Replace_Elmt (Elmt, E);
+ Remove_Homonym (Subp);
end if;
-
- Next_Elmt (Elmt);
- end loop;
-
- Next_Elmt (Iface_Elmt);
- end loop;
-
- return Op_List;
- end Collect_Interface_Primitives;
-
- -------------
- -- In_List --
- -------------
-
- 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;
-
- 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 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
- 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);
+ -- Step 2: Add primitives of progenitors that are not implemented by
+ -- parents of Tagged_Type
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
- Iface := Find_Dispatching_Type (Subp);
+ if Present (Interfaces (Tagged_Type)) then
+ Iface_Elmt := First_Elmt (Interfaces (Tagged_Type));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- if Is_Concurrent_Record_Type (Tagged_Type) then
- if not Present (Abstract_Interface_Alias (Subp)) then
- Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface);
- Append_Elmt (New_Subp, Ifaces_List);
- end if;
+ Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Prim_Elmt) loop
+ Iface_Subp := Node (Prim_Elmt);
- elsif not Is_Parent (Iface, Tagged_Type) then
- Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface);
- Append_Elmt (New_Subp, Ifaces_List);
- end if;
+ if not Is_Predefined_Dispatching_Operation (Iface_Subp) then
+ E := Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Subp);
- Next_Elmt (Elmt);
- end loop;
+ -- If not found we derive a new primitive leaving its alias
+ -- attribute referencing the interface primitive
- -- Complete the derivation of the interface subprograms. Assign 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 No (E) then
+ Derive_Subprogram
+ (New_Subp, Iface_Subp, Tagged_Type, Iface);
- 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;
+ -- Propagate to the full view interface entities associated
+ -- with the partial view
- 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;
+ elsif In_Private_Part (Current_Scope)
+ and then Present (Alias (E))
+ and then Alias (E) = Iface_Subp
+ and then
+ List_Containing (Parent (E)) /=
+ Private_Declarations
+ (Specification
+ (Unit_Declaration_Node (Current_Scope)))
+ then
+ Append_Elmt (E, Primitive_Operations (Tagged_Type));
+ end if;
end if;
- E := Homonym (E);
+ Next_Elmt (Prim_Elmt);
end loop;
- -- Create an overriding entity if not found in the homonym chain
-
- 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_Subprogram (Iface_Subp,
- Is_Abstract_Subprogram (E));
- Remove_Homonym (Iface_Subp);
-
- -- Hidden entities associated with interfaces must have set the
- -- Has_Delay_Freeze attribute to ensure that the corresponding
- -- entry of the secondary dispatch table is filled when such
- -- entity is frozen.
-
- Set_Has_Delayed_Freeze (Iface_Subp);
-
- Next_Elmt (Elmt);
+ Next_Elmt (Iface_Elmt);
end loop;
end if;
- end Derive_Interface_Subprograms;
+ end Derive_Progenitor_Subprograms;
-----------------------
-- Derive_Subprogram --
end if;
end Set_Derived_Name;
+ -- Local variables
+
+ Parent_Overrides_Interface_Primitive : Boolean := False;
+
-- Start of processing for Derive_Subprogram
begin
New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
Set_Ekind (New_Subp, Ekind (Parent_Subp));
+ -- Check whether the parent overrides an interface primitive
+
+ if Is_Overriding_Operation (Parent_Subp) then
+ declare
+ E : Entity_Id := Parent_Subp;
+ begin
+ while Present (Overridden_Operation (E)) loop
+ E := Ultimate_Alias (Overridden_Operation (E));
+ end loop;
+
+ Parent_Overrides_Interface_Primitive :=
+ Is_Dispatching_Operation (E)
+ and then Present (Find_Dispatching_Type (E))
+ and then Is_Interface (Find_Dispatching_Type (E));
+ end;
+ end if;
+
-- Check whether the inherited subprogram is a private operation that
-- should be inherited but not yet made visible. Such subprograms can
-- become visible at a later point (e.g., the private part of a public
then
Set_Derived_Name;
- -- Ada 2005 (AI-251): Hidden entity associated with abstract interface
- -- primitive
+ -- Ada 2005 (AI-251): Regular derivation if the parent subprogram
+ -- overrides an interface primitive because interface primitives
+ -- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
- elsif Present (Abstract_Interface_Alias (Parent_Subp)) then
+ elsif Parent_Overrides_Interface_Primitive then
Set_Derived_Name;
-- The type is inheriting a private operation, so enter
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty)
is
- Op_List : constant Elist_Id :=
- Collect_Primitive_Operations (Parent_Type);
- Ifaces_List : constant Elist_Id := New_Elmt_List;
- Predef_Prims : constant Elist_Id := New_Elmt_List;
+ Op_List : constant Elist_Id :=
+ Collect_Primitive_Operations (Parent_Type);
+
+ function Check_Derived_Type return Boolean;
+ -- Check that all primitive inherited from Parent_Type are found in
+ -- the list of primitives of Derived_Type exactly in the same order.
+
+ function Check_Derived_Type return Boolean is
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ List : Elist_Id;
+ New_Subp : Entity_Id;
+ Op_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ -- Traverse list of entities in the current scope searching for
+ -- an incomplete type whose full-view is derived type
+
+ E := First_Entity (Scope (Derived_Type));
+ while Present (E)
+ and then E /= Derived_Type
+ loop
+ if Ekind (E) = E_Incomplete_Type
+ and then Present (Full_View (E))
+ and then Full_View (E) = Derived_Type
+ then
+ -- Disable this test if Derived_Type completes an incomplete
+ -- type because in such case more primitives can be added
+ -- later to the list of primitives of Derived_Type by routine
+ -- Process_Incomplete_Dependents
+
+ return True;
+ end if;
+
+ E := Next_Entity (E);
+ end loop;
+
+ List := Collect_Primitive_Operations (Derived_Type);
+ Elmt := First_Elmt (List);
+
+ Op_Elmt := First_Elmt (Op_List);
+ while Present (Op_Elmt) loop
+ Subp := Node (Op_Elmt);
+ New_Subp := Node (Elmt);
+
+ -- At this early stage Derived_Type has no entities with attribute
+ -- Interface_Alias. In addition, such primitives are always
+ -- located at the end of the list of primitives of Parent_Type.
+ -- Therefore, if found we can safely stop processing pending
+ -- entities.
+
+ exit when Present (Interface_Alias (Subp));
+
+ -- Handle hidden entities
+
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ and then Is_Hidden (Subp)
+ then
+ if Present (New_Subp)
+ and then Primitive_Names_Match (Subp, New_Subp)
+ then
+ Next_Elmt (Elmt);
+ end if;
+
+ else
+ if not Present (New_Subp)
+ or else Ekind (Subp) /= Ekind (New_Subp)
+ or else not Primitive_Names_Match (Subp, New_Subp)
+ then
+ return False;
+ end if;
+
+ Next_Elmt (Elmt);
+ end if;
+
+ Next_Elmt (Op_Elmt);
+ end loop;
+
+ return True;
+ end Check_Derived_Type;
+
+ -- Local variables
+
+ Alias_Subp : Entity_Id;
Act_List : Elist_Id;
- Act_Elmt : Elmt_Id;
+ Act_Elmt : Elmt_Id := No_Elmt;
+ Act_Subp : Entity_Id := Empty;
Elmt : Elmt_Id;
+ Need_Search : Boolean := False;
New_Subp : Entity_Id := Empty;
Parent_Base : Entity_Id;
Subp : Entity_Id;
+ -- Start of processing for Derive_Subprograms
+
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
and then Has_Discriminants (Parent_Type)
Parent_Base := Parent_Type;
end if;
- -- Derive primitives inherited from the parent. Note that if the generic
- -- actual is present, this is not really a type derivation, it is a
- -- completion within an instance.
-
if Present (Generic_Actual) then
Act_List := Collect_Primitive_Operations (Generic_Actual);
Act_Elmt := First_Elmt (Act_List);
- else
- Act_Elmt := No_Elmt;
end if;
- -- Literals are derived earlier in the process of building the derived
- -- type, and are skipped here.
+ -- Derive primitives inherited from the parent. Note that if the generic
+ -- actual is present, this is not really a type derivation, it is a
+ -- completion within an instance.
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Subp := Node (Elmt);
+ -- Case 1: Derived_Type does not implement interfaces
+
+ if not Is_Tagged_Type (Derived_Type)
+ or else (not Has_Interfaces (Derived_Type)
+ and then not (Present (Generic_Actual)
+ and then
+ Has_Interfaces (Generic_Actual)))
+ then
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
- if Ekind (Subp) /= E_Enumeration_Literal then
+ -- Literals are derived earlier in the process of building the
+ -- derived type, and are skipped here.
- if Ada_Version >= Ada_05
- and then Present (Abstract_Interface_Alias (Subp))
- then
+ if Ekind (Subp) = E_Enumeration_Literal then
null;
- -- We derive predefined primitives in a later round to ensure that
- -- they are always added to the list of primitives after user
- -- defined primitives (because predefined primitives have to be
- -- skipped when matching the operations of a parent interface to
- -- those of a concrete type). However it is unclear why those
- -- primitives would be needed in an instantiation???
+ -- The actual is a direct descendant and the common primitive
+ -- operations appear in the same order.
- elsif Is_Predefined_Dispatching_Operation (Subp) then
- Append_Elmt (Subp, Predef_Prims);
+ -- If the generic parent type is present, the derived type is an
+ -- instance of a formal derived type, and within the instance its
+ -- operations are those of the actual. We derive from the formal
+ -- type but make the inherited operations aliases of the
+ -- corresponding operations of the actual.
- elsif No (Generic_Actual) then
- Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base);
+ else
+ Derive_Subprogram
+ (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
- -- Ada 2005 (AI-251): Add derivation of an abstract interface
- -- primitive to the list of entities to which we have to
- -- associate an aliased entity.
+ if Present (Act_Elmt) then
+ Next_Elmt (Act_Elmt);
+ end if;
+ end if;
- 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))
- then
- Append_Elmt (New_Subp, Ifaces_List);
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Case 2: Derived_Type implements interfaces
+
+ else
+ -- If the parent type has no predefined primitives we remove
+ -- predefined primitives from the list of primitives of generic
+ -- actual to simplify the complexity of this algorithm.
+
+ if Present (Generic_Actual) then
+ declare
+ Has_Predefined_Primitives : Boolean := False;
+
+ begin
+ -- Check if the parent type has predefined primitives
+
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ if Is_Predefined_Dispatching_Operation (Subp)
+ and then not Comes_From_Source (Ultimate_Alias (Subp))
+ then
+ Has_Predefined_Primitives := True;
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Remove predefined primitives of Generic_Actual. We must use
+ -- an auxiliary list because in case of tagged types the value
+ -- returned by Collect_Primitive_Operations is the value stored
+ -- in its Primitive_Operations attribute (and we don't want to
+ -- modify its current contents).
+
+ if not Has_Predefined_Primitives then
+ declare
+ Aux_List : constant Elist_Id := New_Elmt_List;
+
+ begin
+ Elmt := First_Elmt (Act_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ or else Comes_From_Source (Subp)
+ then
+ Append_Elmt (Subp, Aux_List);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Act_List := Aux_List;
+ end;
end if;
- else
- -- If the generic parent type is present, the derived type
- -- is an instance of a formal derived type, and within the
- -- instance its operations are those of the actual. We derive
- -- from the formal type but make the inherited operations
- -- aliases of the corresponding operations of the actual.
-
- if Is_Interface (Parent_Type)
- and then Root_Type (Derived_Type) /= Parent_Type
+ Act_Elmt := First_Elmt (Act_List);
+ Act_Subp := Node (Act_Elmt);
+ end;
+ end if;
+
+ -- Stage 1: If the generic actual is not present we derive the
+ -- primitives inherited from the parent type. If the generic parent
+ -- type is present, the derived type is an instance of a formal
+ -- derived type, and within the instance its operations are those of
+ -- the actual. We derive from the formal type but make the inherited
+ -- operations aliases of the corresponding operations of the actual.
+
+ Elmt := First_Elmt (Op_List);
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+ Alias_Subp := Ultimate_Alias (Subp);
+
+ -- At this early stage Derived_Type has no entities with attribute
+ -- Interface_Alias. In addition, such primitives are always
+ -- located at the end of the list of primitives of Parent_Type.
+ -- Therefore, if found we can safely stop processing pending
+ -- entities.
+
+ exit when Present (Interface_Alias (Subp));
+
+ -- If the generic actual is present find the corresponding
+ -- operation in the generic actual. If the parent type is a
+ -- direct ancestor of the derived type then, even if it is an
+ -- interface, the operations are inherited from the primary
+ -- dispatch table and are in the proper order. If we detect here
+ -- that primitives are not in the same order we traverse the list
+ -- of primitive operations of the actual to find the one that
+ -- implements the interface primitive.
+
+ if Need_Search
+ or else
+ (Present (Generic_Actual)
+ and then Present (Act_Subp)
+ and then not Primitive_Names_Match (Subp, Act_Subp))
+ then
+ pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
+ pragma Assert (Is_Interface (Parent_Base));
+
+ -- Remember that we need searching for all the pending
+ -- primitives
+
+ Need_Search := True;
+
+ -- Handle entities associated with interface primitives
+
+ if Present (Alias (Subp))
+ and then Is_Interface (Find_Dispatching_Type (Alias (Subp)))
+ and then not Is_Predefined_Dispatching_Operation (Subp)
then
- -- Find the corresponding operation in the generic actual.
- -- Given that the actual is not a direct descendant of the
- -- parent, as in Ada 95, the primitives are not necessarily
- -- in the same order, so we have to traverse the list of
- -- primitive operations of the actual to find the one that
- -- implements the interface operation.
-
- -- Note that if the parent type is the direct ancestor of
- -- the derived type, then even if it is an interface the
- -- operations are inherited from the primary dispatch table
- -- and are in the proper order.
+ Act_Subp :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Generic_Actual,
+ Iface_Prim => Subp);
+ -- Handle predefined primitives plus the rest of user-defined
+ -- primitives
+
+ else
Act_Elmt := First_Elmt (Act_List);
while Present (Act_Elmt) loop
- exit when
- Abstract_Interface_Alias (Node (Act_Elmt)) = Subp;
+ Act_Subp := Node (Act_Elmt);
+
+ exit when Primitive_Names_Match (Subp, Act_Subp)
+ and then Type_Conformant (Subp, Act_Subp,
+ Skip_Controlling_Formals => True)
+ and then No (Interface_Alias (Act_Subp));
+
Next_Elmt (Act_Elmt);
end loop;
end if;
+ end if;
- -- If the formal is not an interface, the actual is a direct
- -- descendant and the common primitive operations appear in
- -- the same order.
+ -- Case 1: If the parent is a limited interface then it has the
+ -- predefined primitives of synchronized interfaces. However, the
+ -- actual type may be a non-limited type and hence it does not
+ -- have such primitives.
- Derive_Subprogram
- (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
+ if Present (Generic_Actual)
+ and then not Present (Act_Subp)
+ and then Is_Limited_Interface (Parent_Base)
+ and then Is_Predefined_Interface_Primitive (Subp)
+ then
+ null;
- if Present (Act_Elmt) then
- Next_Elmt (Act_Elmt);
+ -- Case 2: Inherit entities associated with interfaces that
+ -- were not covered by the parent type. We exclude here null
+ -- interface primitives because they do not need special
+ -- management.
+
+ elsif Present (Alias (Subp))
+ and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
+ and then not
+ (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
+ and then Null_Present (Parent (Alias_Subp)))
+ then
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Alias_Subp,
+ Derived_Type => Derived_Type,
+ Parent_Type => Find_Dispatching_Type (Alias_Subp),
+ Actual_Subp => Act_Subp);
+
+ if No (Generic_Actual) then
+ Set_Alias (New_Subp, Subp);
end if;
- end if;
- end if;
- Next_Elmt (Elmt);
- end loop;
+ -- Case 3: Common derivation
- -- Inherit additional operations from progenitor interfaces. However,
- -- if the derived type is a generic actual, there are not new primitive
- -- operations for the type, because it has those of the actual, so
- -- nothing needs to be done. The renamings generated above are not
- -- primitive operations, and their purpose is simply to make the proper
- -- operations visible within an instantiation.
+ else
+ Derive_Subprogram
+ (New_Subp => New_Subp,
+ Parent_Subp => Subp,
+ Derived_Type => Derived_Type,
+ Parent_Type => Parent_Base,
+ Actual_Subp => Act_Subp);
+ end if;
- if Ada_Version >= Ada_05
- and then Is_Tagged_Type (Derived_Type)
- and then No (Generic_Actual)
- then
- Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
- end if;
+ -- No need to update Act_Elm if we must search for the
+ -- corresponding operation in the generic actual
- -- Derive predefined primitives
+ if not Need_Search
+ and then Present (Act_Elmt)
+ then
+ Next_Elmt (Act_Elmt);
+ Act_Subp := Node (Act_Elmt);
+ end if;
- if not Is_Empty_Elmt_List (Predef_Prims) then
- Elmt := First_Elmt (Predef_Prims);
- while Present (Elmt) loop
- Derive_Subprogram
- (New_Subp, Node (Elmt), Derived_Type, Parent_Base);
Next_Elmt (Elmt);
end loop;
+
+ -- Inherit additional operations from progenitors. If the derived
+ -- type is a generic actual, there are not new primitive operations
+ -- for the type because it has those of the actual, and therefore
+ -- nothing needs to be done. The renamings generated above are not
+ -- primitive operations, and their purpose is simply to make the
+ -- proper operations visible within an instantiation.
+
+ if No (Generic_Actual) then
+ Derive_Progenitor_Subprograms (Parent_Base, Derived_Type);
+ end if;
end if;
+
+ -- Final check: Direct descendants must have their primitives in the
+ -- same order. We exclude from this test non-tagged types and instances
+ -- of formal derived types. We skip this test if we have already
+ -- reported serious errors in the sources.
+
+ pragma Assert (not Is_Tagged_Type (Derived_Type)
+ or else Present (Generic_Actual)
+ or else Serious_Errors_Detected > 0
+ or else Check_Derived_Type);
end Derive_Subprograms;
--------------------------------
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean
is
- Iface_Elmt : Elmt_Id;
- I_Name : Entity_Id;
-
begin
- if No (Abstract_Interfaces (Typ)) then
- return False;
-
- else
- Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
- while Present (Iface_Elmt) loop
- I_Name := Node (Iface_Elmt);
- if Base_Type (I_Name) = Base_Type (Iface) then
- return True;
-
- elsif Is_Derived_Type (I_Name)
- and then Is_Ancestor (Iface, I_Name)
- then
- return True;
-
- else
- Next_Elmt (Iface_Elmt);
- end if;
- end loop;
-
- -- For concurrent record types, they have the interfaces of the
- -- parent synchronized type. However these have no ancestors that
- -- implement anything, so assume it is a progenitor.
- -- Should be cleaned up in Collect_Abstract_Interfaces???
-
- if Is_Concurrent_Record_Type (Typ) then
- return Present (Abstract_Interfaces (Typ));
- end if;
-
- -- If type is a derived type, check recursively its ancestors
-
- if Is_Derived_Type (Typ) then
- return Etype (Typ) = Iface
- or else Is_Progenitor (Iface, Etype (Typ));
- else
- return False;
- end if;
- end if;
+ return Implements_Interface (Typ, Iface,
+ Exclude_Parents => True);
end Is_Progenitor;
------------------------------
-- Handle entities in the list of abstract interfaces
- if Present (Abstract_Interfaces (Typ)) then
- Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ if Present (Interfaces (Typ)) then
+ Iface_Elmt := First_Elmt (Interfaces (Typ));
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- If the private view was tagged, copy the new primitive operations
-- from the private view to the full view.
+ -- Note: Subprograms covering interface primitives were previously
+ -- propagated to the full view by Derive_Progenitor_Primitives
+
if Is_Tagged_Type (Full_T)
and then not Is_Concurrent_Type (Full_T)
then
-- These flags must be initialized before calling Process_Discriminants
-- because this routine makes use of them.
- Set_Ekind (T, E_Record_Type);
- Set_Etype (T, T);
- Init_Size_Align (T);
- Set_Abstract_Interfaces (T, No_Elist);
- Set_Stored_Constraint (T, No_Elist);
+ Set_Ekind (T, E_Record_Type);
+ Set_Etype (T, T);
+ Init_Size_Align (T);
+ Set_Interfaces (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
-- Normal case
if Ada_Version >= Ada_05
and then Present (Interface_List (Def))
then
- Check_Abstract_Interfaces (N, Def);
+ Check_Interfaces (N, Def);
declare
Ifaces_List : Elist_Id;
-- 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);
+ Collect_Interfaces
+ (T => T,
+ Ifaces_List => Ifaces_List,
+ Exclude_Parents => True);
- Set_Abstract_Interfaces (T, Ifaces_List);
+ Set_Interfaces (T, Ifaces_List);
end;
end if;
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces.
- if Has_Abstract_Interfaces (T) then
+ if Has_Interfaces (T) then
Add_Interface_Tag_Components (N, T);
end if;
end if;
if Is_Tagged
and then not Is_Empty_List (Interface_List (Def))
then
- declare
- Ifaces_List : constant Elist_Id := New_Elmt_List;
- begin
- Derive_Interface_Subprograms (T, T, Ifaces_List);
- end;
+ Derive_Progenitor_Subprograms (T, T);
end if;
end Record_Type_Declaration;
with Nlists; use Nlists;
with Types; use Types;
-package Sem_Ch3 is
+package Sem_Ch3 is
procedure Analyze_Component_Declaration (N : Node_Id);
procedure Analyze_Incomplete_Type_Decl (N : Node_Id);
procedure Analyze_Itype_Reference (N : Node_Id);
Error_Msg_NE ("no selector& for}", N, Sel);
Check_Misspelled_Selector (Type_To_Use, Sel);
-
end if;
Set_Entity (Sel, Any_Id);
-- primitive is also in this list of primitive operations and
-- will be used instead.
- if (Present (Abstract_Interface_Alias (Prim_Op))
- and then Is_Ancestor (Find_Dispatching_Type
- (Alias (Prim_Op)), Corr_Type))
+ if (Present (Interface_Alias (Prim_Op))
+ and then Is_Ancestor (Find_Dispatching_Type
+ (Alias (Prim_Op)), Corr_Type))
or else
- -- Do not consider hidden primitives unless the type is in an
- -- open scope or we are within an instance, where visibility
- -- is known to be correct.
+ -- Do not consider hidden primitives unless the type is
+ -- in an open scope or we are within an instance, where
+ -- visibility is known to be correct.
(Is_Hidden (Prim_Op)
and then not Is_Immediately_Visible (Obj_Type)
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
and then
- Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id))))
+ Present (Interfaces (Etype (First_Entity (Spec_Id))))
and then
Present
(Corresponding_Concurrent_Type
if (Ekind (Formal_Typ) = E_Protected_Type
or else Ekind (Formal_Typ) = E_Task_Type)
and then Present (Corresponding_Record_Type (Formal_Typ))
- and then Present (Abstract_Interfaces
- (Corresponding_Record_Type (Formal_Typ)))
+ and then Present (Interfaces
+ (Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
-----------------------
procedure Check_Conventions (Typ : Entity_Id) is
+ Ifaces_List : Elist_Id;
- function Skip_Check (Op : Entity_Id) return Boolean;
- pragma Inline (Skip_Check);
- -- A small optimization: skip the predefined dispatching operations,
- -- since they always have the same convention. Also do not consider
- -- abstract primitives since those are left by an erroneous overriding.
- -- This function returns True for any operation that is thus exempted
- -- exempted from checking.
-
- procedure Check_Convention
- (Op : Entity_Id;
- Search_From : Elmt_Id);
+ procedure Check_Convention (Op : Entity_Id);
-- Verify that the convention of inherited dispatching operation Op is
-- consistent among all subprograms it overrides. In order to minimize
-- the search, Search_From is utilized to designate a specific point in
-- Check_Convention --
----------------------
- procedure Check_Convention
- (Op : Entity_Id;
- Search_From : Elmt_Id)
- is
- procedure Error_Msg_Operation (Op : Entity_Id);
- -- Emit a continuation to an error message depicting the kind, name,
- -- convention and source location of subprogram Op.
-
- -------------------------
- -- Error_Msg_Operation --
- -------------------------
+ procedure Check_Convention (Op : Entity_Id) is
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
- procedure Error_Msg_Operation (Op : Entity_Id) is
- begin
- Error_Msg_Name_1 := Chars (Op);
+ begin
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface_Prim_Elmt :=
+ First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
+ while Present (Iface_Prim_Elmt) loop
+ Iface_Prim := Node (Iface_Prim_Elmt);
+
+ if Is_Interface_Conformant (Typ, Iface_Prim, Op)
+ and then Convention (Iface_Prim) /= Convention (Op)
+ then
+ Error_Msg_N
+ ("inconsistent conventions in primitive operations", Typ);
- -- Error messages of primitive subprograms do not contain a
- -- convention attribute since the convention may have been first
- -- inherited from a parent subprogram, then changed by a pragma.
+ Error_Msg_Name_1 := Chars (Op);
+ Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
+ Error_Msg_Sloc := Sloc (Op);
- if Comes_From_Source (Op) then
- Error_Msg_Sloc := Sloc (Op);
- Error_Msg_N
- ("\ primitive % defined #", Typ);
+ if Comes_From_Source (Op) then
+ if not Is_Overriding_Operation (Op) then
+ Error_Msg_N ("\\primitive % defined #", Typ);
+ else
+ Error_Msg_N ("\\overridding operation % with " &
+ "convention % defined #", Typ);
+ end if;
- else
- Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
+ else pragma Assert (Present (Alias (Op)));
+ Error_Msg_Sloc := Sloc (Alias (Op));
+ Error_Msg_N ("\\inherited operation % with " &
+ "convention % defined #", Typ);
+ end if;
- if Present (Abstract_Interface_Alias (Op)) then
- Error_Msg_Sloc := Sloc (Abstract_Interface_Alias (Op));
+ Error_Msg_Name_1 := Chars (Op);
+ Error_Msg_Name_2 :=
+ Get_Convention_Name (Convention (Iface_Prim));
+ Error_Msg_Sloc := Sloc (Iface_Prim);
Error_Msg_N ("\\overridden operation % with " &
"convention % defined #", Typ);
- else pragma Assert (Present (Alias (Op)));
- Error_Msg_Sloc := Sloc (Alias (Op));
- Error_Msg_N ("\\inherited operation % with " &
- "convention % defined #", Typ);
- end if;
- end if;
- end Error_Msg_Operation;
-
- -- Local variables
-
- Second_Prim_Op : Entity_Id;
- Second_Prim_Op_Elmt : Elmt_Id;
-
- -- Start of processing for Check_Convention
-
- begin
- Second_Prim_Op_Elmt := Next_Elmt (Search_From);
- while Present (Second_Prim_Op_Elmt) loop
- Second_Prim_Op := Node (Second_Prim_Op_Elmt);
-
- if not Skip_Check (Second_Prim_Op)
- and then Chars (Second_Prim_Op) = Chars (Op)
- and then Type_Conformant (Second_Prim_Op, Op)
- and then Convention (Second_Prim_Op) /= Convention (Op)
- then
- Error_Msg_N
- ("inconsistent conventions in primitive operations", Typ);
+ -- Avoid cascading errors
- Error_Msg_Operation (Op);
- Error_Msg_Operation (Second_Prim_Op);
-
- -- Avoid cascading errors
+ return;
+ end if;
- return;
- end if;
+ Next_Elmt (Iface_Prim_Elmt);
+ end loop;
- Next_Elmt (Second_Prim_Op_Elmt);
+ Next_Elmt (Iface_Elmt);
end loop;
end Check_Convention;
- ----------------
- -- Skip_Check --
- ----------------
-
- function Skip_Check (Op : Entity_Id) return Boolean is
- begin
- return Is_Predefined_Dispatching_Operation (Op)
- or else Is_Abstract_Subprogram (Op);
- end Skip_Check;
-
-- Local variables
Prim_Op : Entity_Id;
-- Start of processing for Check_Conventions
begin
+ if not Has_Interfaces (Typ) then
+ return;
+ end if;
+
+ Collect_Interfaces (Typ, Ifaces_List);
+
-- The algorithm checks every overriding dispatching operation against
-- all the corresponding overridden dispatching operations, detecting
-- differences in conventions.
Prim_Op := Node (Prim_Op_Elmt);
-- A small optimization: skip the predefined dispatching operations
- -- since they always have the same convention. Also avoid processing
- -- of abstract primitives left from an erroneous overriding.
+ -- since they always have the same convention.
- if not Skip_Check (Prim_Op) then
- Check_Convention
- (Op => Prim_Op,
- Search_From => Prim_Op_Elmt);
+ if not Is_Predefined_Dispatching_Operation (Prim_Op) then
+ Check_Convention (Prim_Op);
end if;
Next_Elmt (Prim_Op_Elmt);
------------------------------
procedure Check_Subtype_Conformant
- (New_Id : Entity_Id;
- Old_Id : Entity_Id;
- Err_Loc : Node_Id := Empty)
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty;
+ Skip_Controlling_Formals : Boolean := False)
is
Result : Boolean;
pragma Warnings (Off, Result);
begin
Check_Conformance
- (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
+ (New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
+ Skip_Controlling_Formals => Skip_Controlling_Formals);
end Check_Subtype_Conformant;
---------------------------
end loop;
end Install_Formals;
+ -----------------------------
+ -- Is_Interface_Conformant --
+ -----------------------------
+
+ function Is_Interface_Conformant
+ (Tagged_Type : Entity_Id;
+ Iface_Prim : Entity_Id;
+ Prim : Entity_Id) return Boolean
+ is
+ begin
+ pragma Assert (Is_Subprogram (Iface_Prim)
+ and then Is_Subprogram (Prim)
+ and then Is_Dispatching_Operation (Iface_Prim)
+ and then Is_Dispatching_Operation (Prim));
+
+ pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
+ or else (Present (Alias (Iface_Prim))
+ and then
+ Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
+
+ if Prim = Iface_Prim
+ or else not Is_Subprogram (Prim)
+ or else Ekind (Prim) /= Ekind (Iface_Prim)
+ or else not Is_Dispatching_Operation (Prim)
+ or else Scope (Prim) /= Scope (Tagged_Type)
+ or else No (Find_Dispatching_Type (Prim))
+ or else Base_Type (Find_Dispatching_Type (Prim)) /= Tagged_Type
+ or else not Primitive_Names_Match (Iface_Prim, Prim)
+ then
+ return False;
+
+ -- Case of a procedure, or a function not returning an interface
+
+ elsif Ekind (Iface_Prim) = E_Procedure
+ or else Etype (Prim) = Etype (Iface_Prim)
+ or else not Is_Interface (Etype (Iface_Prim))
+ then
+ return Type_Conformant (Prim, Iface_Prim,
+ Skip_Controlling_Formals => True);
+
+ -- Case of a function returning an interface
+
+ elsif Implements_Interface (Etype (Prim), Etype (Iface_Prim)) then
+ declare
+ Ret_Typ : constant Entity_Id := Etype (Prim);
+ Is_Conformant : Boolean;
+
+ begin
+ -- Temporarly set both entities returning exactly the same type to
+ -- be able to call Type_Conformant (because that routine has no
+ -- machinery to handle interfaces).
+
+ Set_Etype (Prim, Etype (Iface_Prim));
+
+ Is_Conformant :=
+ Type_Conformant (Prim, Iface_Prim,
+ Skip_Controlling_Formals => True);
+
+ -- Restore proper decoration of returned type
+
+ Set_Etype (Prim, Ret_Typ);
+
+ return Is_Conformant;
+ end;
+ end if;
+
+ return False;
+ end Is_Interface_Conformant;
+
---------------------------------
-- Is_Non_Overriding_Operation --
---------------------------------
N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
- Collect_Abstract_Interfaces (Typ, Ifaces_List);
+ Collect_Interfaces (Typ, Ifaces_List);
if not Is_Empty_Elmt_List (Ifaces_List) then
Overridden_Subp :=
and then Is_Dispatching_Operation (Alias (S))
and then Present (Find_Dispatching_Type (Alias (S)))
and then Is_Interface (Find_Dispatching_Type (Alias (S)))
- and then not Is_Predefined_Dispatching_Operation (Alias (S))
then
goto Add_New_Entity;
end if;
-- Subtype_Conformant --
------------------------
- function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
+ function Subtype_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Skip_Controlling_Formals : Boolean := False) return Boolean
+ is
Result : Boolean;
begin
- Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
+ Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
+ Skip_Controlling_Formals => Skip_Controlling_Formals);
return Result;
end Subtype_Conformant;
-- Is_Primitive indicates whether the subprogram is primitive.
procedure Check_Subtype_Conformant
- (New_Id : Entity_Id;
- Old_Id : Entity_Id;
- Err_Loc : Node_Id := Empty);
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Err_Loc : Node_Id := Empty;
+ Skip_Controlling_Formals : Boolean := False);
-- Check that two callable entities (subprograms, entries, literals)
-- are subtype conformant, post error message if not (RM 6.3.1(16))
-- the flag being placed on the Err_Loc node if it is specified, and
-- procedure is also used to get visibility to the formals when analyzing
-- preconditions and postconditions appearing in the spec.
+ function Is_Interface_Conformant
+ (Tagged_Type : Entity_Id;
+ Iface_Prim : Entity_Id;
+ Prim : Entity_Id) return Boolean;
+ -- Returns true if both primitives have a matching name and they are also
+ -- type conformant. Special management is done for functions returning
+ -- interfaces.
+
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are mode conformant (RM 6.3.1(15))
procedure Set_Formal_Mode (Formal_Id : Entity_Id);
-- Set proper Ekind to reflect formal mode (in, out, in out)
- function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
+ function Subtype_Conformant
+ (New_Id : Entity_Id;
+ Old_Id : Entity_Id;
+ Skip_Controlling_Formals : Boolean := False) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are subtype conformant (RM6.3.1(16)).
if Present (Interface_List (N))
or else (Is_Tagged_Type (Priv_T)
- and then Has_Abstract_Interfaces
- (Priv_T, Use_Full_View => False))
+ and then Has_Interfaces
+ (Priv_T, Use_Full_View => False))
then
if Is_Tagged_Type (Priv_T) then
- Collect_Abstract_Interfaces
+ Collect_Interfaces
(Priv_T, Priv_T_Ifaces, Use_Full_View => False);
end if;
if Is_Tagged_Type (T) then
- Collect_Abstract_Interfaces (T, Full_T_Ifaces);
+ Collect_Interfaces (T, Full_T_Ifaces);
end if;
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
Tagged_Type := Corresponding_Record_Type (Tagged_Type);
end if;
+ -- (AI-345): The task body procedure is not a primitive of the tagged
+ -- type
+
+ if Present (Tagged_Type)
+ and then Is_Concurrent_Record_Type (Tagged_Type)
+ and then Present (Corresponding_Concurrent_Type (Tagged_Type))
+ and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type))
+ and then Subp = Get_Task_Body_Procedure
+ (Corresponding_Concurrent_Type (Tagged_Type))
+ then
+ return;
+ end if;
+
-- If Subp is derived from a dispatching operation then it should
-- always be treated as dispatching. In this case various checks
-- below will be bypassed. Makes sure that late declarations for
-- Now it should be a correct primitive operation, put it in the list
if Present (Old_Subp) then
+
+ -- If the type has interfaces we complete this check after we
+ -- set attribute Is_Dispatching_Operation
+
Check_Subtype_Conformant (Subp, Old_Subp);
if (Chars (Subp) = Name_Initialize
Prim := Node (Elmt);
if Present (Alias (Prim))
- and then Present (Abstract_Interface_Alias (Prim))
+ and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
then
Register_Primitive (Sloc (Prim),
Set_Is_Dispatching_Operation (Subp, True);
+ -- Ada 2005 (AI-251): If the type implements interfaces we must check
+ -- subtype conformance against all the interfaces covered by this
+ -- primitive.
+
+ if Present (Old_Subp)
+ and then Has_Interfaces (Tagged_Type)
+ then
+ declare
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Prim_Elmt : Elmt_Id;
+ Iface_Prim : Entity_Id;
+ Ret_Typ : Entity_Id;
+
+ begin
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
+ Iface_Prim_Elmt :=
+ First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
+ while Present (Iface_Prim_Elmt) loop
+ Iface_Prim := Node (Iface_Prim_Elmt);
+
+ if Is_Interface_Conformant
+ (Tagged_Type, Iface_Prim, Subp)
+ then
+ -- Handle procedures, functions whose return type
+ -- matches, or functions not returning interfaces
+
+ if Ekind (Subp) = E_Procedure
+ or else Etype (Iface_Prim) = Etype (Subp)
+ or else not Is_Interface (Etype (Iface_Prim))
+ then
+ Check_Subtype_Conformant
+ (New_Id => Subp,
+ Old_Id => Iface_Prim,
+ Err_Loc => Subp,
+ Skip_Controlling_Formals => True);
+
+ -- Handle functions returning interfaces
+
+ elsif Implements_Interface
+ (Etype (Subp), Etype (Iface_Prim))
+ then
+ -- Temporarily force both entities to return the
+ -- same type. Required because Subtype_Conformant
+ -- does not handle this case.
+
+ Ret_Typ := Etype (Iface_Prim);
+ Set_Etype (Iface_Prim, Etype (Subp));
+
+ Check_Subtype_Conformant
+ (New_Id => Subp,
+ Old_Id => Iface_Prim,
+ Err_Loc => Subp,
+ Skip_Controlling_Formals => True);
+
+ Set_Etype (Iface_Prim, Ret_Typ);
+ end if;
+ end if;
+
+ Next_Elmt (Iface_Prim_Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+
if not Body_Is_Last_Primitive then
Set_DT_Position (Subp, No_Uint);
if Derives_From (Node (Op1)) then
if No (Prev) then
- Prepend_Elmt (Subp, New_Prim);
+
+ -- Avoid adding it to the list of primitives if already there!
+
+ if Node (Op2) /= Subp then
+ Prepend_Elmt (Subp, New_Prim);
+ end if;
+
else
Insert_Elmt_After (Subp, Prev);
end if;
return Empty;
end Find_Dispatching_Type;
+ ---------------------------------------
+ -- Find_Primitive_Covering_Interface --
+ ---------------------------------------
+
+ function Find_Primitive_Covering_Interface
+ (Tagged_Type : Entity_Id;
+ Iface_Prim : Entity_Id) return Entity_Id
+ is
+ E : Entity_Id;
+
+ begin
+ pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
+ or else (Present (Alias (Iface_Prim))
+ and then
+ Is_Interface
+ (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
+
+ E := Current_Entity (Iface_Prim);
+ while Present (E) loop
+ if Is_Subprogram (E)
+ and then Is_Dispatching_Operation (E)
+ and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
+ then
+ return E;
+ end if;
+
+ E := Homonym (E);
+ end loop;
+
+ return Empty;
+ end Find_Primitive_Covering_Interface;
+
---------------------------
-- Is_Dynamically_Tagged --
---------------------------
Replace_Elmt (Elmt, New_Op);
if Ada_Version >= Ada_05
- and then Has_Abstract_Interfaces (Tagged_Type)
+ and then Has_Interfaces (Tagged_Type)
then
-- Ada 2005 (AI-251): Update the attribute alias of all the aliased
-- entities of the overridden primitive to reference New_Op, and also
-- operations that it implements (for operations inherited from the
-- parent itself, this check is made when building the derived type).
+ -- Note: This code is only executed in case of late overriding
+
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
Prim := Node (Elmt);
-- reading attributes in entities that are not yet fully decorated
elsif Is_Subprogram (Prim)
- and then Present (Abstract_Interface_Alias (Prim))
+ and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Prev_Op
and then Present (Etype (New_Op))
then
Set_Alias (Prim, New_Op);
Check_Subtype_Conformant (New_Op, Prim);
- Set_Is_Abstract_Subprogram
- (Prim, Is_Abstract_Subprogram (New_Op));
+ Set_Is_Abstract_Subprogram (Prim,
+ Is_Abstract_Subprogram (New_Op));
-- Ensure that this entity will be expanded to fill the
-- corresponding entry in its dispatch table.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Check whether a subprogram is dispatching, and find the tagged
-- type of the controlling argument or arguments.
+ function Find_Primitive_Covering_Interface
+ (Tagged_Type : Entity_Id;
+ Iface_Prim : Entity_Id) return Entity_Id;
+ -- Search in the homonym chain for the primitive of Tagged_Type that
+ -- covers Iface_Prim. The homonym chain traversal is required to catch
+ -- primitives associated with the partial view of private types when
+ -- processing the corresponding full view.
+
function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
-- Used to determine whether a call is dispatching, i.e. if is an
-- an expression of a class_Wide type, or a call to a function with
elsif Is_Hidden (E)
and then Is_Subprogram (E)
- and then Present (Abstract_Interface_Alias (E))
+ and then Present (Interface_Alias (E))
then
-- Ada 2005 (AI-251): If this primitive operation corresponds with
-- an immediate ancestor interface there is no need to add it to the
-- subprograms which are in fact the same.
if not Is_Ancestor
- (Find_Dispatching_Type (Abstract_Interface_Alias (E)),
+ (Find_Dispatching_Type (Interface_Alias (E)),
Find_Dispatching_Type (E))
then
- Add_One_Interp (N, Abstract_Interface_Alias (E), T);
+ Add_One_Interp (N, Interface_Alias (E), T);
end if;
return;
-- Literals are compatible with types in a given "class"
- elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
+ elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
-- Note: test for presence of E is defense against previous error.
if Present (E)
- and then Present (Abstract_Interfaces (E))
+ and then Present (Interfaces (E))
then
- Elmt := First_Elmt (Abstract_Interfaces (E));
+ Elmt := First_Elmt (Interfaces (E));
while Present (Elmt) loop
if Is_Ancestor (Etype (T1), Node (Elmt)) then
return True;
return True;
elsif Is_Type (T1)
- and then Is_Generic_Actual_Type (T1)
+ and then Is_Generic_Actual_Type (T1)
and then Full_View_Covers (T2, T1)
then
return True;
end if;
loop
- if Present (Abstract_Interfaces (E))
- and then Present (Abstract_Interfaces (E))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
+ if Present (Interfaces (E))
+ and then Present (Interfaces (E))
+ and then not Is_Empty_Elmt_List (Interfaces (E))
then
- Elmt := First_Elmt (Abstract_Interfaces (E));
+ Elmt := First_Elmt (Interfaces (E));
while Present (Elmt) loop
AI := Node (Elmt);
if Etype (AI) = Iface_Typ then
return True;
- elsif Present (Abstract_Interfaces (Etype (AI)))
+ elsif Present (Interfaces (Etype (AI)))
and then Iface_Present_In_Ancestor (Etype (AI))
then
return True;
with Debug; use Debug;
with Errout; use Errout;
with Elists; use Elists;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
end if;
end Check_VMS;
- ---------------------------------
- -- Collect_Abstract_Interfaces --
- ---------------------------------
+ ------------------------
+ -- Collect_Interfaces --
+ ------------------------
- procedure Collect_Abstract_Interfaces
- (T : Entity_Id;
- Ifaces_List : out Elist_Id;
- Exclude_Parent_Interfaces : Boolean := False;
- Use_Full_View : Boolean := True)
+ procedure Collect_Interfaces
+ (T : Entity_Id;
+ Ifaces_List : out Elist_Id;
+ Exclude_Parents : Boolean := False;
+ Use_Full_View : Boolean := True)
is
- procedure Add_Interface (Iface : Entity_Id);
- -- Add the interface it if is not already in the list
-
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
- function Interface_Present_In_Parent
- (Typ : Entity_Id;
- Iface : Entity_Id) return Boolean;
- -- Typ must be a tagged record type/subtype and Iface must be an
- -- abstract interface type. This function is used to check if Typ
- -- or some parent of Typ implements Iface.
-
- -------------------
- -- Add_Interface --
- -------------------
-
- procedure Add_Interface (Iface : Entity_Id) is
- Elmt : Elmt_Id;
-
- begin
- Elmt := First_Elmt (Ifaces_List);
- while Present (Elmt) and then Node (Elmt) /= Iface loop
- Next_Elmt (Elmt);
- end loop;
-
- if No (Elmt) then
- Append_Elmt (Iface, Ifaces_List);
- end if;
- end Add_Interface;
-
-------------
-- Collect --
-------------
procedure Collect (Typ : Entity_Id) is
Ancestor : Entity_Id;
Full_T : Entity_Id;
- Iface_List : List_Id;
Id : Node_Id;
Iface : Entity_Id;
Full_T := Full_View (Typ);
end if;
- Iface_List := Abstract_Interface_List (Full_T);
-
-- Include the ancestor if we are generating the whole list of
-- abstract interfaces.
- -- In concurrent types the ancestor interface (if any) is the
- -- first element of the list of interface types.
-
- if Is_Concurrent_Type (Full_T)
- or else Is_Concurrent_Record_Type (Full_T)
- then
- if Is_Non_Empty_List (Iface_List) then
- Ancestor := Etype (First (Iface_List));
- Collect (Ancestor);
-
- if not Exclude_Parent_Interfaces then
- Add_Interface (Ancestor);
- end if;
- end if;
-
- elsif Etype (Full_T) /= Typ
+ if Etype (Full_T) /= Typ
-- Protect the frontend against wrong sources. For example:
Collect (Ancestor);
if Is_Interface (Ancestor)
- and then not Exclude_Parent_Interfaces
+ and then not Exclude_Parents
then
- Add_Interface (Ancestor);
+ Append_Unique_Elmt (Ancestor, Ifaces_List);
end if;
end if;
-- Traverse the graph of ancestor interfaces
- if Is_Non_Empty_List (Iface_List) then
- Id := First (Iface_List);
-
- -- In concurrent types the ancestor interface (if any) is the
- -- first element of the list of interface types and we have
- -- already processed them while climbing to the root type.
-
- if Is_Concurrent_Type (Full_T)
- or else Is_Concurrent_Record_Type (Full_T)
- then
- Next (Id);
- end if;
-
+ if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
+ Id := First (Abstract_Interface_List (Full_T));
while Present (Id) loop
Iface := Etype (Id);
-- type Wrong is new I and O with null record; -- ERROR
if Is_Interface (Iface) then
- if Exclude_Parent_Interfaces
- and then Interface_Present_In_Parent (T, Iface)
+ if Exclude_Parents
+ and then Etype (T) /= T
+ and then Interface_Present_In_Ancestor (Etype (T), Iface)
then
null;
else
- Collect (Iface);
- Add_Interface (Iface);
+ Collect (Iface);
+ Append_Unique_Elmt (Iface, Ifaces_List);
end if;
end if;
end if;
end Collect;
- ---------------------------------
- -- Interface_Present_In_Parent --
- ---------------------------------
-
- function Interface_Present_In_Parent
- (Typ : Entity_Id;
- Iface : Entity_Id) return Boolean
- is
- Aux : Entity_Id := Typ;
- Iface_List : List_Id;
-
- begin
- if Is_Concurrent_Type (Typ)
- or else Is_Concurrent_Record_Type (Typ)
- then
- Iface_List := Abstract_Interface_List (Typ);
-
- if Is_Non_Empty_List (Iface_List) then
- Aux := Etype (First (Iface_List));
- else
- return False;
- end if;
- end if;
-
- return Interface_Present_In_Ancestor (Aux, Iface);
- end Interface_Present_In_Parent;
-
- -- Start of processing for Collect_Abstract_Interfaces
+ -- Start of processing for Collect_Interfaces
begin
pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
Ifaces_List := New_Elmt_List;
Collect (T);
- end Collect_Abstract_Interfaces;
+ end Collect_Interfaces;
----------------------------------
-- Collect_Interface_Components --
-- Start of processing for Collect_Interfaces_Info
begin
- Collect_Abstract_Interfaces (T, Ifaces_List);
+ Collect_Interfaces (T, Ifaces_List);
Collect_Interface_Components (T, Comps_List);
-- Search for the record component and tag associated with each
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
- if Is_Parent (Iface, T) then
+ if Is_Ancestor (Iface, T) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
Comp_Iface := Related_Type (Node (Comp_Elmt));
if Comp_Iface = Iface
- or else Is_Parent (Iface, Comp_Iface)
+ or else Is_Ancestor (Iface, Comp_Iface)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
end Get_Task_Body_Procedure;
- -----------------------------
- -- Has_Abstract_Interfaces --
- -----------------------------
-
- function Has_Abstract_Interfaces
- (T : Entity_Id;
- Use_Full_View : Boolean := True) return Boolean
- is
- Typ : Entity_Id;
-
- begin
- -- Handle concurrent types
-
- if Is_Concurrent_Type (T) then
- Typ := Corresponding_Record_Type (T);
- else
- Typ := T;
- end if;
-
- if not Present (Typ)
- or else not Is_Tagged_Type (Typ)
- then
- return False;
- end if;
-
- pragma Assert (Is_Record_Type (Typ));
-
- -- Handle private types
-
- if Use_Full_View
- and then Present (Full_View (Typ))
- then
- Typ := Full_View (Typ);
- end if;
-
- -- Handle concurrent record types
-
- if Is_Concurrent_Record_Type (Typ)
- and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
- then
- return True;
- end if;
-
- loop
- if Is_Interface (Typ)
- or else
- (Is_Record_Type (Typ)
- and then Present (Abstract_Interfaces (Typ))
- and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
- then
- return True;
- end if;
-
- exit when Etype (Typ) = Typ
-
- -- Handle private types
-
- or else (Present (Full_View (Etype (Typ)))
- and then Full_View (Etype (Typ)) = Typ)
-
- -- Protect the frontend against wrong source with cyclic
- -- derivations
-
- or else Etype (Typ) = T;
-
- -- Climb to the ancestor type handling private types
-
- if Present (Full_View (Etype (Typ))) then
- Typ := Full_View (Etype (Typ));
- else
- Typ := Etype (Typ);
- end if;
- end loop;
-
- return False;
- end Has_Abstract_Interfaces;
-
-----------------------
-- Has_Access_Values --
-----------------------
and then Includes_Infinities (Scalar_Range (E));
end Has_Infinities;
+ --------------------
+ -- Has_Interfaces --
+ --------------------
+
+ function Has_Interfaces
+ (T : Entity_Id;
+ Use_Full_View : Boolean := True) return Boolean
+ is
+ Typ : Entity_Id;
+
+ begin
+ -- Handle concurrent types
+
+ if Is_Concurrent_Type (T) then
+ Typ := Corresponding_Record_Type (T);
+ else
+ Typ := T;
+ end if;
+
+ if not Present (Typ)
+ or else not Is_Record_Type (Typ)
+ or else not Is_Tagged_Type (Typ)
+ then
+ return False;
+ end if;
+
+ -- Handle private types
+
+ if Use_Full_View
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle concurrent record types
+
+ if Is_Concurrent_Record_Type (Typ)
+ and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
+ then
+ return True;
+ end if;
+
+ loop
+ if Is_Interface (Typ)
+ or else
+ (Is_Record_Type (Typ)
+ and then Present (Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Interfaces (Typ)))
+ then
+ return True;
+ end if;
+
+ exit when Etype (Typ) = Typ
+
+ -- Handle private types
+
+ or else (Present (Full_View (Etype (Typ)))
+ and then Full_View (Etype (Typ)) = Typ)
+
+ -- Protect the frontend against wrong source with cyclic
+ -- derivations
+
+ or else Etype (Typ) = T;
+
+ -- Climb to the ancestor type handling private types
+
+ if Present (Full_View (Etype (Typ))) then
+ Typ := Full_View (Etype (Typ));
+ else
+ Typ := Etype (Typ);
+ end if;
+ end loop;
+
+ return False;
+ end Has_Interfaces;
+
------------------------
-- Has_Null_Exclusion --
------------------------
end if;
end Has_Tagged_Component;
+ --------------------------
+ -- Implements_Interface --
+ --------------------------
+
+ function Implements_Interface
+ (Typ_Ent : Entity_Id;
+ Iface_Ent : Entity_Id;
+ Exclude_Parents : Boolean := False) return Boolean
+ is
+ Ifaces_List : Elist_Id;
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if Is_Class_Wide_Type (Typ_Ent) then
+ Typ := Etype (Typ_Ent);
+ else
+ Typ := Typ_Ent;
+ end if;
+
+ if Is_Class_Wide_Type (Iface_Ent) then
+ Iface := Etype (Iface_Ent);
+ else
+ Iface := Iface_Ent;
+ end if;
+
+ if not Has_Interfaces (Typ) then
+ return False;
+ end if;
+
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ Elmt := First_Elmt (Ifaces_List);
+ while Present (Elmt) loop
+ if Is_Ancestor (Node (Elmt), Typ)
+ and then Exclude_Parents
+ then
+ null;
+
+ elsif Node (Elmt) = Iface then
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ return False;
+ end Implements_Interface;
+
-----------------
-- In_Instance --
-----------------
end if;
end Is_OK_Variable_For_Out_Formal;
- ---------------
- -- Is_Parent --
- ---------------
-
- function Is_Parent
- (E1 : Entity_Id;
- E2 : Entity_Id) return Boolean
- is
- Iface_List : List_Id;
- T : Entity_Id := E2;
-
- begin
- if Is_Concurrent_Type (T)
- or else Is_Concurrent_Record_Type (T)
- then
- Iface_List := Abstract_Interface_List (E2);
-
- if Is_Empty_List (Iface_List) then
- return False;
- end if;
-
- T := Etype (First (Iface_List));
- end if;
-
- return Is_Ancestor (E1, T);
- end Is_Parent;
-
-----------------------------------
-- Is_Partially_Initialized_Type --
-----------------------------------
return Trace_Components (Type_Id, False);
end Private_Component;
+ ---------------------------
+ -- Primitive_Names_Match --
+ ---------------------------
+
+ function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
+
+ function Non_Internal_Name (E : Entity_Id) return Name_Id;
+ -- Given an internal name, returns the corresponding non-internal name
+
+ ------------------------
+ -- Non_Internal_Name --
+ ------------------------
+
+ function Non_Internal_Name (E : Entity_Id) return Name_Id is
+ begin
+ Get_Name_String (Chars (E));
+ Name_Len := Name_Len - 1;
+ return Name_Find;
+ end Non_Internal_Name;
+
+ -- Start of processing for Primitive_Names_Match
+
+ begin
+ pragma Assert (Present (E1) and then Present (E2));
+
+ return Chars (E1) = Chars (E2)
+ or else
+ (not Is_Internal_Name (Chars (E1))
+ and then Is_Internal_Name (Chars (E2))
+ and then Non_Internal_Name (E2) = Chars (E1))
+ or else
+ (not Is_Internal_Name (Chars (E2))
+ and then Is_Internal_Name (Chars (E1))
+ and then Non_Internal_Name (E1) = Chars (E2))
+ or else
+ (Is_Predefined_Dispatching_Operation (E1)
+ and then Is_Predefined_Dispatching_Operation (E2)
+ and then Same_TSS (E1, E2))
+ or else
+ (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
+ end Primitive_Names_Match;
+
-----------------------
-- Process_End_Label --
-----------------------
return Token_Node;
end Real_Convert;
+ --------------------
+ -- Remove_Homonym --
+ --------------------
+
+ procedure Remove_Homonym (E : Entity_Id) is
+ Prev : Entity_Id := Empty;
+ H : Entity_Id;
+
+ begin
+ if E = Current_Entity (E) then
+ if Present (Homonym (E)) then
+ Set_Current_Entity (Homonym (E));
+ else
+ Set_Name_Entity_Id (Chars (E), Empty);
+ end if;
+ 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 Remove_Homonym;
+
---------------------
-- Rep_To_Pos_Flag --
---------------------
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
+ --------------------
+ -- Ultimate_Alias --
+ --------------------
+ -- To do: add occurrences calling this new subprogram
+
+ function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := Prim;
+
+ begin
+ while Present (Alias (E)) loop
+ E := Alias (E);
+ end loop;
+
+ return E;
+ end Ultimate_Alias;
+
--------------------------
-- Unit_Declaration_Node --
--------------------------
-- with OpenVMS ports. The argument is the construct in question
-- and is used to post the error message.
- procedure Collect_Abstract_Interfaces
- (T : Entity_Id;
- Ifaces_List : out Elist_Id;
- Exclude_Parent_Interfaces : Boolean := False;
- Use_Full_View : Boolean := True);
+ procedure Collect_Interfaces
+ (T : Entity_Id;
+ Ifaces_List : out Elist_Id;
+ Exclude_Parents : Boolean := False;
+ Use_Full_View : Boolean := True);
-- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are
- -- directly or indirectly implemented by T. Exclude_Parent_Interfaces is
- -- used to avoid addition of inherited interfaces to the generated list.
+ -- directly or indirectly implemented by T. Exclude_Parents is used to
+ -- avoid the addition of inherited interfaces to the generated list.
-- Use_Full_View is used to collect the interfaces using the full-view
-- (if available).
-- as an access type internally, this function tests only for access types
-- known to the programmer. See also Has_Tagged_Component.
- function Has_Abstract_Interfaces
- (T : Entity_Id;
- Use_Full_View : Boolean := True) return Boolean;
- -- Where T is a concurrent type or a record type, returns true if T covers
- -- any abstract interface types. In case of private types the argument
- -- Use_Full_View controls if the check is done using its full view (if
- -- available).
-
type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible);
-- Result of Has_Compatible_Alignment test, description found below. Note
-- that the values are arranged in increasing order of problematicness.
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
+ function Has_Interfaces
+ (T : Entity_Id;
+ Use_Full_View : Boolean := True) return Boolean;
+ -- Where T is a concurrent type or a record type, returns true if T covers
+ -- any abstract interface types. In case of private types the argument
+ -- Use_Full_View controls if the check is done using its full view (if
+ -- available).
+
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
-- component is present. This function is used to check if '=' has to be
-- expanded into a bunch component comparisons.
+ function Implements_Interface
+ (Typ_Ent : Entity_Id;
+ Iface_Ent : Entity_Id;
+ Exclude_Parents : Boolean := False) return Boolean;
+ -- Returns true if the Typ implements interface Iface
+
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
-- is a variable (in the Is_Variable sense) with a non-tagged type
-- target are considered view conversions and hence variables.
- function Is_Parent
- (E1 : Entity_Id;
- E2 : Entity_Id) return Boolean;
- -- Determine whether E1 is a parent of E2. For a concurrent type, the
- -- parent is the first element of its list of interface types; for other
- -- types, this function provides the same result as Is_Ancestor.
-
function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is
-- partly initialized, meaning that an object of the type is at least
-- For convenience, qualified expressions applied to object names
-- are also allowed as actuals for this function.
+ function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean;
+ -- Returns True if the names of both entities correspond with matching
+ -- primitives. This routine includes support for the case in which one
+ -- or both entities correspond with entities built by Derive_Subprogram
+ -- with a special name to avoid being overriden (ie. return true in case
+ -- of entities with names "nameP" and "name" or viceversa).
+
function Private_Component (Type_Id : Entity_Id) return Entity_Id;
-- Returns some private component (if any) of the given Type_Id.
-- Used to enforce the rules on visibility of operations on composite
-- S is a possibly signed syntactically valid real literal. The result
-- returned is an N_Real_Literal node representing the literal value.
+ procedure Remove_Homonym (E : Entity_Id);
+ -- Removes E from the homonym chain
+
function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id;
-- This is used to construct the second argument in a call to Rep_To_Pos
-- which is Standard_True if range checks are enabled (E is an entity to
function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ
+ function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
+ -- Return the last entity in the chain of aliased entities of Prim.
+ -- If Prim has no alias return Prim.
+
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the
Write_Str_With_Col_Check_Sloc ("new ");
Sprint_Node (Subtype_Mark (Node));
+ if Present (Interface_List (Node)) then
+ Write_Str_With_Col_Check (" and ");
+ Sprint_And_List (Interface_List (Node));
+ end if;
+
if Private_Present (Node) then
Write_Str_With_Col_Check (" with private");
end if;
Write_Str_With_Col_Check (" is new ");
Sprint_Node (Subtype_Indication (Node));
+
+ if Present (Interface_List (Node)) then
+ Write_Str_With_Col_Check (" and ");
+ Sprint_And_List (Interface_List (Node));
+ end if;
+
Write_Str_With_Col_Check (" with private;");
when N_Procedure_Call_Statement =>
projects / gcc.git / commitdiff