[Ada] Spurious error on overriding protected function in instance

The conformance between an overriding protected operation with
progenitors and the overridden interface operation requires subtype
conformance; requiring equality of return types in the case of a
function is too restrictive and leads to spurious errors when the return
type is a generic actual.

2018-08-21  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch6.adb (Check_Synchronized_Overriding): The conformance
	between an overriding protected operation and the overridden
	abstract progenitor operation requires subtype conformance;
	requiring equality of return types in the case of a function is
	too restrictive and leads to spurious errors when the return
	type is a generic actual.

gcc/testsuite/

	* gnat.dg/prot6.adb, gnat.dg/prot6.ads: New testcase.

From-SVN: r263731

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 98045633fbf53518854015a8976572b21c56f2e4..ff886ebd7893a76a1109f2943f6ad14bc0b3588d 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-08-21  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch6.adb (Check_Synchronized_Overriding): The conformance
+       between an overriding protected operation and the overridden
+       abstract progenitor operation requires subtype conformance;
+       requiring equality of return types in the case of a function is
+       too restrictive and leads to spurious errors when the return
+       type is a generic actual.
+
 2018-08-21  Ed Schonberg  <schonberg@adacore.com>
 
        * exp_ch9.adb (Expand_N_Timed_Entry_Call,

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 2dd9d2f42872903b8bad65e651394311059a72f3..2ddd3d35767f69470dc2e4050ec428613d4e352b 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -7440,13 +7440,15 @@ package body Sem_Ch6 is
                end;
 
             --  Functions can override abstract interface functions
+            --  Return types must be subtype conformant.
 
             elsif Ekind (Def_Id) = E_Function
               and then Ekind (Subp) = E_Function
               and then Matches_Prefixed_View_Profile
                          (Parameter_Specifications (Parent (Def_Id)),
                           Parameter_Specifications (Parent (Subp)))
-              and then Etype (Def_Id) = Etype (Subp)
+              and then Conforming_Types (Etype (Def_Id), Etype (Subp),
+                Subtype_Conformant)
             then
                Candidate := Subp;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index eccca9b0349de9bec4b7b66aed1c8817358a0423..ddc6e0dc13bd30ed0f941bb9d285b76988659598 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-08-21  Ed Schonberg  <schonberg@adacore.com>
+
+       * gnat.dg/prot6.adb, gnat.dg/prot6.ads: New testcase.
+
 2018-08-21  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/access5.adb, gnat.dg/access5.ads: New testcase.

diff --git a/gcc/testsuite/gnat.dg/prot6.adb b/gcc/testsuite/gnat.dg/prot6.adb
new file mode 100644 (file)
index 0000000..f33b0a2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/prot6.adb
@@ -0,0 +1,20 @@
+--  { dg-do compile }
+--  { dg-options "-gnatc" }
+
+package body Prot6 is
+
+   protected body My_Type is
+
+      procedure Set (D : Integer) is
+      begin
+         I := D;
+      end Set;
+
+      function Get return Integer is
+      begin
+         return I;
+      end Get;
+   end My_Type;
+
+   procedure Dummy is null;
+end Prot6;

diff --git a/gcc/testsuite/gnat.dg/prot6.ads b/gcc/testsuite/gnat.dg/prot6.ads
new file mode 100644 (file)
index 0000000..d8e27e0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/prot6.ads
@@ -0,0 +1,31 @@
+package Prot6 is
+
+   generic
+      type TD is private;
+      type TI is synchronized interface;
+   package Set_Get is
+      type T is synchronized interface and TI;
+
+      procedure Set (E : in out T; D : TD) is abstract;
+      function Get (E : T) return TD is abstract;
+   end Set_Get;
+
+   type My_Type_Interface is synchronized interface;
+
+   package Set_Get_Integer is
+     new Set_Get (TD => Integer,
+                  TI => My_Type_Interface);
+   use Set_Get_Integer;
+
+   protected type My_Type is
+        new Set_Get_Integer.T with
+
+      overriding procedure Set (D : Integer);
+      overriding function Get return Integer;
+   private
+      I : Integer;
+   end My_Type;
+
+   procedure Dummy;
+
+end Prot6;