re PR fortran/63733 ([OOP] wrong resolution for OPERATOR generics)

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/63733
	* interface.c (gfc_extend_expr): Look for type-bound operators before
	non-typebound ones.

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/63733
	* gfortran.dg/typebound_operator_20.f90: New.

From-SVN: r219440

4 files changed, 108 insertions, 49 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6f2e549..5af89b9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2015-01-11  Janus Weil  <janus@gcc.gnu.org>
 
+	PR fortran/63733
+	* interface.c (gfc_extend_expr): Look for type-bound operators before
+	non-typebound ones.
+
+2015-01-11  Janus Weil  <janus@gcc.gnu.org>
+
 	PR fortran/58023
 	* resolve.c (resolve_fl_derived0): Set error flag if problems with the
 	interface of a procedure-pointer component were detected.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ca9751f..dd3ad2a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3720,6 +3720,8 @@ gfc_extend_expr (gfc_expr *e)
   gfc_user_op *uop;
   gfc_intrinsic_op i;
   const char *gname;
+  gfc_typebound_proc* tbo;
+  gfc_expr* tb_base;
 
   sym = NULL;
 
@@ -3736,6 +3738,48 @@ gfc_extend_expr (gfc_expr *e)
 
   i = fold_unary_intrinsic (e->value.op.op);
 
+  /* See if we find a matching type-bound operator.  */
+  if (i == INTRINSIC_USER)
+    tbo = matching_typebound_op (&tb_base, actual,
+				  i, e->value.op.uop->name, &gname);
+  else
+    switch (i)
+      {
+#define CHECK_OS_COMPARISON(comp) \
+  case INTRINSIC_##comp: \
+  case INTRINSIC_##comp##_OS: \
+    tbo = matching_typebound_op (&tb_base, actual, \
+				 INTRINSIC_##comp, NULL, &gname); \
+    if (!tbo) \
+      tbo = matching_typebound_op (&tb_base, actual, \
+				   INTRINSIC_##comp##_OS, NULL, &gname); \
+    break;
+	CHECK_OS_COMPARISON(EQ)
+	CHECK_OS_COMPARISON(NE)
+	CHECK_OS_COMPARISON(GT)
+	CHECK_OS_COMPARISON(GE)
+	CHECK_OS_COMPARISON(LT)
+	CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+	default:
+	  tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
+	  break;
+      }
+
+  /* If there is a matching typebound-operator, replace the expression with
+      a call to it and succeed.  */
+  if (tbo)
+    {
+      gcc_assert (tb_base);
+      build_compcall_for_operator (e, actual, tb_base, tbo, gname);
+
+      if (!gfc_resolve_expr (e))
+	return MATCH_ERROR;
+      else
+	return MATCH_YES;
+    }
+ 
   if (i == INTRINSIC_USER)
     {
       for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -3786,58 +3830,9 @@ gfc_extend_expr (gfc_expr *e)
 
   if (sym == NULL)
     {
-      gfc_typebound_proc* tbo;
-      gfc_expr* tb_base;
-
-      /* See if we find a matching type-bound operator.  */
-      if (i == INTRINSIC_USER)
-	tbo = matching_typebound_op (&tb_base, actual,
-				     i, e->value.op.uop->name, &gname);
-      else
-	switch (i)
-	  {
-#define CHECK_OS_COMPARISON(comp) \
-  case INTRINSIC_##comp: \
-  case INTRINSIC_##comp##_OS: \
-    tbo = matching_typebound_op (&tb_base, actual, \
-				 INTRINSIC_##comp, NULL, &gname); \
-    if (!tbo) \
-      tbo = matching_typebound_op (&tb_base, actual, \
-				   INTRINSIC_##comp##_OS, NULL, &gname); \
-    break;
-	    CHECK_OS_COMPARISON(EQ)
-	    CHECK_OS_COMPARISON(NE)
-	    CHECK_OS_COMPARISON(GT)
-	    CHECK_OS_COMPARISON(GE)
-	    CHECK_OS_COMPARISON(LT)
-	    CHECK_OS_COMPARISON(LE)
-#undef CHECK_OS_COMPARISON
-
-	    default:
-	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
-	      break;
-	  }
-
-      /* If there is a matching typebound-operator, replace the expression with
-	 a call to it and succeed.  */
-      if (tbo)
-	{
-	  bool result;
-
-	  gcc_assert (tb_base);
-	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
-
-	  result = gfc_resolve_expr (e);
-	  if (!result)
-	    return MATCH_ERROR;
-
-	  return MATCH_YES;
-	}
-
       /* Don't use gfc_free_actual_arglist().  */
       free (actual->next);
       free (actual);
-
       return MATCH_NO;
     }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4f729fd..b3b6b59 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2015-01-11  Janus Weil  <janus@gcc.gnu.org>
 
+	PR fortran/63733
+	* gfortran.dg/typebound_operator_20.f90: New.
+
+2015-01-11  Janus Weil  <janus@gcc.gnu.org>
+
 	PR fortran/58023
 	* gfortran.dg/proc_ptr_comp_42.f90: New.
 
diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_20.f90 b/gcc/testsuite/gfortran.dg/typebound_operator_20.f90
new file mode 100644
index 0000000..26c49a1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_20.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+!
+! PR 63733: [4.8/4.9/5 Regression] [OOP] wrong resolution for OPERATOR generics
+!
+! Original test case from Alberto F. Martín Huertas <amartin@cimne.upc.edu>
+! Slightly modified by Salvatore Filippone <sfilippone@uniroma2.it>
+! Further modified by Janus Weil <janus@gcc.gnu.org>
+
+module overwrite
+  type parent
+   contains
+     procedure :: sum => sum_parent
+     generic   :: operator(+) => sum
+  end type
+
+  type, extends(parent) ::  child
+  contains
+    procedure :: sum => sum_child
+  end type
+
+contains
+
+  integer function sum_parent(op1,op2)
+    implicit none
+    class(parent), intent(in) :: op1, op2
+    sum_parent = 0
+  end function
+
+  integer function sum_child(op1,op2)
+    implicit none
+    class(child) , intent(in) :: op1
+    class(parent), intent(in) :: op2
+    sum_child = 1
+  end function
+
+end module
+
+program drive
+  use overwrite
+  implicit none
+
+  type(parent) :: m1, m2
+  class(parent), pointer :: mres
+  type(child)  :: h1, h2
+  class(parent), pointer :: hres
+
+  if (m1 + m2 /= 0) call abort()
+  if (h1 + m2 /= 1) call abort()
+  if (h1%sum(h2) /= 1) call abort()
+
+end
+
+! { dg-final { cleanup-modules "overwrite" } }