[Ada] Spurious error on non-default C++ constructor

The frontend reports spurious errors on C++ non-default constructors
that have formals whose type is an access to subprogram.

2019-07-04  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_tss.adb (Init_Proc): Adding missing support for access to
	subprograms and access to protected subprograms of non-default
	C++ constructors.

gcc/testsuite/

	* gnat.dg/cpp_constructor.adb, gnat.dg/cpp_constructor_fp.ads,
	gnat.dg/cpp_constructor_useit.ads: New testcase.

From-SVN: r273072

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3ea8e477e8a534c100eeff2d9f645927de8cba22..45c5f39cb8784ebd46d8b394d5a19883bc24ea5a 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-04  Javier Miranda  <miranda@adacore.com>
+
+       * exp_tss.adb (Init_Proc): Adding missing support for access to
+       subprograms and access to protected subprograms of non-default
+       C++ constructors.
+
 2019-07-04  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat1drv.adb (Adjust_Global_Switches): Use proper interface to

diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index 388be4864060cc0019a099d9dec3a061fc0da774..8ef05e23d3ed8cfe24ba65996ac00ac2e59951e7 100644 (file)
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -32,6 +32,7 @@ with Lib;      use Lib;
 with Restrict; use Restrict;
 with Rident;   use Rident;
 with Sem_Aux;  use Sem_Aux;
+with Sem_Ch6;  use Sem_Ch6;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 
@@ -275,8 +276,8 @@ package body Exp_Tss is
                   then
                      exit;
 
-                  elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
-                    and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
+                  elsif not Is_Anonymous_Access_Type (Etype (E1))
+                    and then not Is_Anonymous_Access_Type (Etype (E2))
                     and then Etype (E1) /= Etype (E2)
                   then
                      exit;
@@ -287,6 +288,17 @@ package body Exp_Tss is
                                /= Directly_Designated_Type (Etype (E2))
                   then
                      exit;
+
+                  elsif Ekind_In (Etype (E1),
+                          E_Anonymous_Access_Subprogram_Type,
+                          E_Anonymous_Access_Protected_Subprogram_Type)
+                    and then Ekind_In (Etype (E2),
+                               E_Anonymous_Access_Subprogram_Type,
+                               E_Anonymous_Access_Protected_Subprogram_Type)
+                    and then not Conforming_Types
+                                   (Etype (E1), Etype (E2), Fully_Conformant)
+                  then
+                     exit;
                   end if;
 
                   E1 := Next_Formal (E1);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index dd1aa0dc14a61185402252721663b1cccc9251b3..89601758400fbc80af9536086f66f6ec5a328a5a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-07-04  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/cpp_constructor.adb, gnat.dg/cpp_constructor_fp.ads,
+       gnat.dg/cpp_constructor_useit.ads: New testcase.
+
 2019-07-04  Gary Dismukes  <dismukes@adacore.com>
 
        * gnat.dg/ghost5.adb, gnat.dg/ghost5.ads,

diff --git a/gcc/testsuite/gnat.dg/cpp_constructor.adb b/gcc/testsuite/gnat.dg/cpp_constructor.adb
new file mode 100644 (file)
index 0000000..1ecae1b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/cpp_constructor.adb
@@ -0,0 +1,12 @@
+--  { dg-do compile }
+
+with Interfaces.C; use Interfaces.C;
+with Cpp_Constructor_FP;
+with Cpp_Constructor_Useit;
+
+procedure Cpp_Constructor is
+   F : Cpp_Constructor_FP.Class :=
+     Cpp_Constructor_FP.Constructor (Cpp_Constructor_Useit.My_Fn'Access);
+begin
+   null;
+end Cpp_Constructor;

diff --git a/gcc/testsuite/gnat.dg/cpp_constructor_fp.ads b/gcc/testsuite/gnat.dg/cpp_constructor_fp.ads
new file mode 100644 (file)
index 0000000..3ee4b3e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/cpp_constructor_fp.ads
@@ -0,0 +1,10 @@
+with Interfaces.C; use Interfaces.C;
+
+package Cpp_Constructor_FP is
+   type Class is limited record null; end record
+   with Convention => Cpp, Import;
+
+   function Constructor
+     (Fn : access function (Val : int) return int) return Class;
+   pragma Cpp_Constructor (Constructor, External_Name => "foo");
+end Cpp_Constructor_FP;

diff --git a/gcc/testsuite/gnat.dg/cpp_constructor_useit.ads b/gcc/testsuite/gnat.dg/cpp_constructor_useit.ads
new file mode 100644 (file)
index 0000000..1f30464
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/cpp_constructor_useit.ads
@@ -0,0 +1,8 @@
+with Interfaces.C; use Interfaces.C;
+
+package Cpp_Constructor_Useit is
+   function My_Fn (Val : int) return int
+   with Convention => Cpp;
+
+   function My_Fn (Val : int) return int is (Val + 1);
+end Cpp_Constructor_Useit;