[Ada] Checks on instantiations with formal derived types with interfaces

This patch implements the rule stated in RM 12.5.5 : the actual shall be
a descendant of very progenitor of the formal type.

2018-05-25  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch12.adb (Validate_Derived_Type_Instance): Verify that the actual
	for a formal derived type implements all the interfaces declared for
	the formal.

gcc/testsuite/

	* gnat.dg/interface6.adb: New testcase.

From-SVN: r260723

4 files changed, 96 insertions, 0 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index a6fb325..adb62f5 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-05-25  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch12.adb (Validate_Derived_Type_Instance): Verify that the actual
+	for a formal derived type implements all the interfaces declared for
+	the formal.
+
 2018-05-25  Yannick Moy  <moy@adacore.com>
 
 	* sem_prag.adb (Check_Applicable_Policy): Deal specially with CodePeer
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index c8d4df0..bc7dd13 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3fff973..a3c2ff9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
 2018-05-25  Ed Schonberg  <schonberg@adacore.com>
 
+	* gnat.dg/interface6.adb: New testcase.
+
+2018-05-25  Ed Schonberg  <schonberg@adacore.com>
+
 	* gnat.dg/static_pred1.adb, gnat.dg/static_pred1.ads: New testcase.
 
 2018-05-25  Richard Sandiford  <richard.sandiford@linaro.org>
diff --git a/gcc/testsuite/gnat.dg/interface6.adb b/gcc/testsuite/gnat.dg/interface6.adb
new file mode 100644
index 0000000..04eb1e1
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/interface6.adb
@@ -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;