From: Ed Schonberg <schonberg@adacore.com>
Date: Tue, 21 Aug 2018 14:48:03 +0000 (+0000)
Subject: [Ada] Spurious error on overriding protected function in instance
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=24241bd0388ec6f730788540b289da12c13a34cc;p=gcc.git

[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 98045633fbf..ff886ebd789 100644
--- 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 2dd9d2f4287..2ddd3d35767 100644
--- 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 eccca9b0349..ddc6e0dc13b 100644
--- 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
index 00000000000..f33b0a2429d
--- /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
index 00000000000..d8e27e0a73b
--- /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;