re PR fortran/78108 (Generic type-bound operator conflicts)

2016-10-26  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78108
	* resolve.c (resolve_typebound_intrinsic_op): For submodules
	suppress the error and return if the same procedure symbol
	is added more than once to the interface.

2016-10-26  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78108
	* gfortran.dg/submodule_18.f08: New test.
	* gfortran.dg/submodule_19.f08: New test.

From-SVN: r241555

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 65911dc7302fa31ce866703613907d11aa313b14..bae08b8c8ac568b4fb72c1994ac324afef439aff 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2016-10-26  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/78108
+       * resolve.c (resolve_typebound_intrinsic_op): For submodules
+       suppress the error and return if the same procedure symbol
+       is added more than once to the interface.
+
 2016-10-26  Fritz Reese <fritzoreese@gmail.com>
 
        * frontend-passes.c (gfc_code_walker): Add SHARE and CARRIAGECONTROL.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 785203b4dc271cc3d7f28e5b605d830d61678ee6..fe966aa537dbe05a5a99218023d65878e02dfa72 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -12797,7 +12797,17 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
          && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns)
        {
          gfc_interface *head, *intr;
-         if (!gfc_check_new_interface (derived->ns->op[op], target_proc, p->where))
+
+         /* Preempt 'gfc_check_new_interface' for submodules, where the
+            mechanism for handling module procedures winds up resolving
+            operator interfaces twice and would otherwise cause an error.  */
+         for (intr = derived->ns->op[op]; intr; intr = intr->next)
+           if (intr->sym == target_proc
+               && target_proc->attr.used_in_submodule)
+             return true;
+
+         if (!gfc_check_new_interface (derived->ns->op[op],
+                                       target_proc, p->where))
            return false;
          head = derived->ns->op[op];
          intr = gfc_get_interface ();

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a5049cf89cd2d645629aeade38238e3af39e16bb..84dc56df1135cbc0770184a6cb21293459320027 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-10-26  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/78108
+       * gfortran.dg/submodule_18.f08: New test.
+       * gfortran.dg/submodule_19.f08: New test.
+
 2016-10-26  Michael Matz  <matz@suse.de>
 
        * g++.dg/pr78060.C: New test.

diff --git a/gcc/testsuite/gfortran.dg/submodule_18.f08 b/gcc/testsuite/gfortran.dg/submodule_18.f08
new file mode 100644 (file)
index 0000000..14fac75
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/submodule_18.f08
@@ -0,0 +1,49 @@
+! { dg-do run }
+!
+! Tests the fix for PR78108 in which an error was
+! triggered by the module procedures being added twice
+! to the operator interfaces.
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+module foo_interface
+  implicit none
+  type foo
+    integer :: x
+  contains
+    procedure :: add
+    generic :: operator(+) => add
+    procedure :: mult
+    generic :: operator(*) => mult
+  end type
+  interface
+    integer module function add(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+    end function
+    integer module function mult(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+    end function
+  end interface
+end module
+submodule(foo_interface) foo_implementation
+contains
+    integer module function add(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+      add = lhs % x + rhs % x
+    end function
+    integer module function mult(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+      mult = lhs % x * rhs % x
+    end function
+end submodule
+
+  use foo_interface
+  type(foo) :: a = foo (42)
+  type(foo) :: b = foo (99)
+  if (a + b .ne. 141) call abort
+  if (a * b .ne. 4158) call abort
+end

diff --git a/gcc/testsuite/gfortran.dg/submodule_19.f08 b/gcc/testsuite/gfortran.dg/submodule_19.f08
new file mode 100644 (file)
index 0000000..bc84008
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/submodule_19.f08
@@ -0,0 +1,59 @@
+! { dg-do compile }
+!
+! Tests the fix for PR78108 in which an error was triggered by the
+! generic operator being resolved more than once in submodules. This
+! test checks that the error is triggered when the specific procedure
+! really is inserted more than once in the interface.
+!
+! Note that adding the extra interface to the module produces two
+! errors; the one below and 'Duplicate EXTERNAL attribute specified at (1)'
+!
+! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+!
+module foo_interface
+  implicit none
+  type foo
+    integer :: x
+  contains
+    procedure :: add
+    generic :: operator(+) => add
+    procedure :: mult
+    generic :: operator(*) => mult
+  end type
+  interface
+    integer module function add(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+    end function
+    integer module function mult(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+    end function
+  end interface
+end module
+submodule(foo_interface) foo_implementation
+  interface operator (+)
+    integer module function add(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+    end function    ! { dg-error "is already present in the interface" }
+  end interface
+contains
+    integer module function add(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+      add = lhs % x + rhs % x
+    end function
+    integer module function mult(lhs,rhs)
+      implicit none
+      class(foo), intent(in) :: lhs,rhs
+      mult = lhs % x * rhs % x
+    end function
+end submodule
+
+  use foo_interface
+  type(foo) :: a = foo (42)
+  type(foo) :: b = foo (99)
+  if (a + b .ne. 141) call abort
+  if (a * b .ne. 4158) call abort
+end