===================================================================
@@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
@@ -1537,90 +1538,92 @@ package body Sem_Ch3 is
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).
+ -- Originally we excluded here from this processing interfaces that
+ -- are parents of Tagged_Type because their primitives are located
+ -- in the primary dispatch table (and hence no auxiliary internal
+ -- entities are required to handle secondary dispatch tables in such
+ -- case). However, these auxiliary entities are also required to
+ -- handle derivations of interfaces in formals of generics (see
+ -- Derive_Subprograms).
- 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);
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
- if No (Prim) then
+ if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+ Prim :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Prim);
+
+ if No (Prim) then
+
+ -- In some rare cases, a name conflict may have kept the
+ -- operation completely hidden. Look for it in the list
+ -- of primitive operations of the type.
- -- In some rare cases, a name conflict may have kept the
- -- operation completely hidden. Look for it in the list
- -- of primitive operations of the type.
+ declare
+ El : Elmt_Id;
- declare
- El : Elmt_Id;
- begin
- El := First_Elmt (Primitive_Operations (Tagged_Type));
- while Present (El) loop
- Prim := Node (El);
- exit when Is_Subprogram (Prim)
- and then Alias (Prim) = Iface_Prim;
- Next_Elmt (El);
- end loop;
+ begin
+ El := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (El) loop
+ Prim := Node (El);
+ exit when Is_Subprogram (Prim)
+ and then Alias (Prim) = Iface_Prim;
+ Next_Elmt (El);
+ end loop;
- -- If the operation was not explicitly overridden, it
- -- should have been inherited as an abstract operation
- -- so Prim can not be Empty at this stage.
+ -- If the operation was not explicitly overridden, it
+ -- should have been inherited as an abstract operation
+ -- so Prim can not be Empty at this stage.
- if No (El) then
- raise Program_Error;
- end if;
- end;
- end if;
+ if No (El) then
+ raise Program_Error;
+ end if;
+ end;
+ end if;
- 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 an entity is frozen.
+ 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 an entity is frozen.
- Set_Has_Delayed_Freeze (New_Subp);
- end if;
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
- Next_Elmt (Elmt);
- end loop;
- end if;
+ Next_Elmt (Elmt);
+ end loop;
Next_Elmt (Iface_Elmt);
end loop;
@@ -11955,7 +11958,7 @@ package body Sem_Ch3 is
-- 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).
+ -- by Add_Internal_Interface_Entities).
if In_Private_Part (Current_Scope)
and then Is_Abstract_Type (Parent_Type)
@@ -12734,6 +12737,12 @@ package body Sem_Ch3 is
-- corresponding operations of the actual.
else
+ pragma Assert (No (Node (Act_Elmt))
+ or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
+ and then
+ Type_Conformant (Subp, Node (Act_Elmt),
+ Skip_Controlling_Formals => True)));
+
Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
@@ -12839,7 +12848,11 @@ package body Sem_Ch3 is
or else
(Present (Generic_Actual)
and then Present (Act_Subp)
- and then not Primitive_Names_Match (Subp, Act_Subp))
+ and then not
+ (Primitive_Names_Match (Subp, Act_Subp)
+ and then
+ Type_Conformant (Subp, Act_Subp,
+ Skip_Controlling_Formals => True)))
then
pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
@@ -12849,14 +12862,73 @@ package body Sem_Ch3 is
-- Handle entities associated with interface primitives
- if Present (Alias (Subp))
- and then Is_Interface (Find_Dispatching_Type (Alias (Subp)))
+ if Present (Alias_Subp)
+ and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
and then not Is_Predefined_Dispatching_Operation (Subp)
then
+ -- Search for the primitive in the homonym chain
+
Act_Subp :=
Find_Primitive_Covering_Interface
(Tagged_Type => Generic_Actual,
- Iface_Prim => Subp);
+ Iface_Prim => Alias_Subp);
+
+ -- Previous search may not locate primitives covering
+ -- interfaces defined in generics units or instantiations.
+ -- (it fails if the covering primitive has formals whose
+ -- type is also defined in generics or instantiations).
+ -- In such case we search in the list of primitives of the
+ -- generic actual for the internal entity that links the
+ -- interface primitive and the covering primitive.
+
+ if No (Act_Subp)
+ and then Is_Generic_Type (Parent_Type)
+ then
+ -- This code has been designed to handle only generic
+ -- formals that implement interfaces that are defined
+ -- in a generic unit or instantiation. If this code is
+ -- needed for other cases we must review it because
+ -- (given that it relies on Original_Location to locate
+ -- the primitive of Generic_Actual that covers the
+ -- interface) it could leave linked through attribute
+ -- Alias entities of unrelated instantiations).
+
+ pragma Assert
+ (Is_Generic_Unit
+ (Scope (Find_Dispatching_Type (Alias_Subp)))
+ or else
+ Instantiation_Depth
+ (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
+
+ declare
+ Iface_Prim_Loc : constant Source_Ptr :=
+ Original_Location (Sloc (Alias_Subp));
+ Elmt : Elmt_Id;
+ Prim : Entity_Id;
+ begin
+ Elmt :=
+ First_Elmt (Primitive_Operations (Generic_Actual));
+
+ Search : while Present (Elmt) loop
+ Prim := Node (Elmt);
+
+ if Present (Interface_Alias (Prim))
+ and then Original_Location
+ (Sloc (Interface_Alias (Prim)))
+ = Iface_Prim_Loc
+ then
+ Act_Subp := Alias (Prim);
+ exit Search;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop Search;
+ end;
+ end if;
+
+ pragma Assert (Present (Act_Subp)
+ or else Is_Abstract_Type (Generic_Actual)
+ or else Serious_Errors_Detected > 0);
-- Handle predefined primitives plus the rest of user-defined
-- primitives
@@ -12874,6 +12946,10 @@ package body Sem_Ch3 is
Next_Elmt (Act_Elmt);
end loop;
+
+ if No (Act_Elmt) then
+ Act_Subp := Empty;
+ end if;
end if;
end if;
===================================================================
@@ -4497,15 +4497,13 @@ package body Sem_Util is
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
- Typ : Entity_Id;
+ Typ : Entity_Id := Base_Type (T);
begin
-- Handle concurrent types
- if Is_Concurrent_Type (T) then
- Typ := Corresponding_Record_Type (T);
- else
- Typ := T;
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
end if;
if not Present (Typ)
===================================================================
@@ -4568,7 +4568,7 @@ package body Sem_Ch6 is
elsif Must_Override (Spec) then
if Is_Overriding_Operation (Subp) then
- Set_Is_Overriding_Operation (Subp);
+ null;
elsif not Can_Override then
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
@@ -6477,8 +6477,8 @@ package body Sem_Ch6 is
or else Etype (Prim) = Etype (Iface_Prim)
or else not Has_Controlling_Result (Prim)
then
- return Type_Conformant (Prim, Iface_Prim,
- Skip_Controlling_Formals => True);
+ return Type_Conformant
+ (Iface_Prim, Prim, Skip_Controlling_Formals => True);
-- Case of a function returning an interface, or an access to one.
-- Check that the return types correspond.
===================================================================
@@ -6014,6 +6014,9 @@ package body Exp_Disp is
-- Look for primitive overriding an abstract interface subprogram
if Present (Interface_Alias (Prim))
+ and then not
+ Is_Ancestor
+ (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then
Prim_Pos := DT_Position (Alias (Prim));
@@ -6721,6 +6724,13 @@ package body Exp_Disp is
pragma Assert (Is_Interface (Iface_Typ));
+ -- No action needed for interfaces that are ancestors of Typ because
+ -- their primitives are located in the primary dispatch table.
+
+ if Is_Ancestor (Iface_Typ, Tag_Typ) then
+ return L;
+ end if;
+
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if not Is_Ancestor (Iface_Typ, Tag_Typ)
===================================================================
@@ -2366,7 +2366,9 @@ package body Sem_Ch13 is
-- code because their main purpose was to provide support to initialize
-- the secondary dispatch tables. They are now generated also when
-- compiling with no code generation to provide ASIS the relationship
- -- between interface primitives and tagged type primitives.
+ -- between interface primitives and tagged type primitives. They are
+ -- also used to locate primitives covering interfaces when processing
+ -- generics (see Derive_Subprograms).
if Ada_Version >= Ada_05
and then Ekind (E) = E_Record_Type
@@ -2374,6 +2376,12 @@ package body Sem_Ch13 is
and then not Is_Interface (E)
and then Has_Interfaces (E)
then
+ -- This would be a good common place to call the routine that checks
+ -- overriding of interface primitives (and thus factorize calls to
+ -- Check_Abstract_Overriding located at different contexts in the
+ -- compiler). However, this is not possible because it causes
+ -- spurious errors in case of late overriding.
+
Add_Internal_Interface_Entities (E);
end if;
end Analyze_Freeze_Entity;
===================================================================
@@ -572,7 +572,11 @@ package body Exp_CG is
Prim_Op := Node (Prim_Elmt);
Int_Alias := Interface_Alias (Prim_Op);
- if Present (Int_Alias) and then (Alias (Prim_Op)) = Prim then
+ if Present (Int_Alias)
+ and then not Is_Ancestor
+ (Find_Dispatching_Type (Int_Alias), Typ)
+ and then (Alias (Prim_Op)) = Prim
+ then
Write_Char (',');
Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
Write_Char (':');
This patch improves the derivation of generic formals that are types that cover interfaces. Previous support required only name consistency; the new implementation is more complete because types of arguments are also checked. The following test now compiles silently. generic package Gen is type Root is abstract tagged null record; type Rec is record null; end record; type Iface is interface; procedure Prim1 (Obj : Iface; R : Rec) is abstract; procedure Prim2 (Obj : Iface; R : Rec) is abstract; type Iface2 is interface; procedure Prim1 (Obj : Iface2; R : Rec; V : Natural) is abstract; type Iface3 is interface and Iface; type DT2 is new Root and Iface2 and Iface3 with null record; procedure Prim1 (Obj : DT2; R : Rec; V : Natural); procedure Prim2 (Obj : DT2; R : Rec); procedure Prim1 (Obj : DT2; R : Rec); end; with Gen; generic with package Formal_Pkg is new Gen; type Formal_Type is new Formal_Pkg.Root and Formal_Pkg.Iface with private; package Test_Matching_Formals is procedure Do_Test; end; package body Test_Matching_Formals is procedure Do_Test is Obj1 : Formal_Pkg.DT2; Obj2 : Formal_Type; Rec : Formal_Pkg.Rec; begin Formal_Pkg.Iface'Class (Obj1).Prim1 (Rec); Formal_Pkg.Iface'Class (Obj2).Prim1 (Rec); end; end; with Gen; with Test_Matching_Formals; package Main_Pkg is package Root_Inst is new Gen; package Test_Pkg is new Test_Matching_Formals ( Formal_Pkg => Root_Inst, Formal_Type => Root_Inst.DT2); procedure Do_Test; end; package body Main_Pkg is procedure Do_Test is Obj : Root_Inst.DT2; Rec : Root_Inst.Rec; begin Root_Inst.Iface'Class (Obj).Prim1 (Rec); end; end; package body Gen is procedure Prim1 (Obj : DT2; R : Rec; V : Natural) is begin raise Program_Error; end; procedure Prim2 (Obj : DT2; R : Rec) is begin null; end; procedure Prim1 (Obj : DT2; R : Rec) is begin null; end; end; with Main_Pkg; use Main_Pkg; procedure Test_Iface_Formals is begin Do_Test; Test_Pkg.Do_Test; end Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-23 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal entities for parent types that are interfaces. Needed in generics to handle formals that implement interfaces. (Derive_Subprograms): Add assertion for derivation of tagged types that do not cover interfaces. For generics, complete code that handles derivation of type that covers interfaces because the previous condition was weak (it required only name consistency; arguments were not checked). Add new code to locate primitives covering interfaces defined in generic units or instantiatons. * sem_util.adb (Has_Interfaces): Add missing support for derived types. * sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups. * exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of interfaces that are parents of the type because they share the primary dispatch table. (Register_Primitive): Do not register primitives of interfaces that are parents of the type. * sem_ch13.adb (Analyze_Freeze_Entity): Add documentation. * exp_cg.adb (Write_Type_Info): When displaying overriding of interface primitives skip primitives of interfaces that are parents of the type.