@@ -12356,6 +12356,48 @@ package body Sem_Ch12 is
Ancestor_Discr : Entity_Id;
begin
+ -- Verify that the actual includes the progenitors of the formal,
+ -- if any. The formal may depend on previous formals and their
+ -- instance, so we must examine instance of interfaces if present.
+ -- The actual may be an extension of an interface, in which case
+ -- it does not appear in the interface list, so this must be
+ -- checked separately.
+ -- We omit the check if the interface is declared in an (enclosing)
+ -- generic because the interface implemented by the actual may have
+ -- the same name but a different entity. A small remaining gap ???
+
+ if Present (Interface_List (Def)) then
+ if not Has_Interfaces (Act_T) then
+ Error_Msg_NE
+ ("actual must implement all interfaces of formal&",
+ Actual, A_Gen_T);
+
+ else
+ declare
+ Iface : Node_Id;
+ Iface_Ent : Entity_Id;
+
+ begin
+ Iface := First (Abstract_Interface_List (A_Gen_T));
+
+ while Present (Iface) loop
+ Iface_Ent := Get_Instance_Of (Entity (Iface));
+ if not Is_Progenitor (Iface_Ent, Act_T)
+ and then not Is_Ancestor (Iface_Ent, Act_T)
+ and then Ekind (Scope (Iface_Ent)) /= E_Generic_Package
+ then
+ Error_Msg_Name_1 := Chars (Act_T);
+ Error_Msg_NE
+ ("Actual% must implement interface&",
+ Actual, Etype (Iface));
+ end if;
+
+ Next (Iface);
+ end loop;
+ end;
+ end if;
+ end if;
+
-- If the parent type in the generic declaration is itself a previous
-- formal type, then it is local to the generic and absent from the
-- analyzed generic definition. In that case the ancestor is the
new file mode 100644
@@ -0,0 +1,44 @@
+-- { dg-do compile }
+
+procedure Interface6 is
+
+ type TI is interface;
+ type TI2 is interface;
+
+ type Rec_Type is tagged null record;
+
+ type Rec_Type1 is new TI
+ with
+ record
+ A : Integer;
+ end record;
+
+ type Rec_Type2 is new Rec_Type1 and TI2
+ with
+ record
+ B : Integer;
+ end record;
+
+ type Rec_Type12 is new Rec_Type1 and TI and TI2
+ with
+ record
+ C : Integer;
+ end record;
+
+ generic
+ type T is new Rec_Type1 and TI2 with private;
+ procedure Test;
+
+ procedure Test is
+ begin
+ null;
+ end Test;
+
+ procedure Test_Instance1 is new Test (T => Rec_Type); -- { dg-error "actual must implement all interfaces of formal \"T\"" }
+ procedure Test_Instance1 is new Test (T => Rec_Type1); -- { dg-error "Actual \"Rec_Type1\" must implement interface \"TI2\"" }
+ procedure Test_Instance2 is new Test (T => Rec_Type2);
+ procedure Test_Instance12 is new Test (T => Rec_Type12);
+
+begin
+ null;
+end Interface6;