From 24241bd0388ec6f730788540b289da12c13a34cc Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 21 Aug 2018 14:48:03 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/sem_ch6.adb | 4 +++- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/prot6.adb | 20 ++++++++++++++++++++ gcc/testsuite/gnat.dg/prot6.ads | 31 +++++++++++++++++++++++++++++++ 5 files changed, 67 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/prot6.adb create mode 100644 gcc/testsuite/gnat.dg/prot6.ads 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 + + * 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 * 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 + + * gnat.dg/prot6.adb, gnat.dg/prot6.ads: New testcase. + 2018-08-21 Ed Schonberg * 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; -- 2.30.2