From a036d1de575622d6cc7efb8d1de75ce9c4a27de4 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Fri, 25 May 2018 09:03:41 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 6 ++++ gcc/ada/sem_ch12.adb | 42 ++++++++++++++++++++++++++ gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/interface6.adb | 44 ++++++++++++++++++++++++++++ 4 files changed, 96 insertions(+) create mode 100644 gcc/testsuite/gnat.dg/interface6.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a6fb3257cac..adb62f5b3c5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-05-25 Ed Schonberg + + * 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 * 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 c8d4df06629..bc7dd138a1b 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 3fff97300b1..a3c2ff9ccb0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-25 Ed Schonberg + + * gnat.dg/interface6.adb: New testcase. + 2018-05-25 Ed Schonberg * gnat.dg/static_pred1.adb, gnat.dg/static_pred1.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/interface6.adb b/gcc/testsuite/gnat.dg/interface6.adb new file mode 100644 index 00000000000..04eb1e17999 --- /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; -- 2.30.2