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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6f2e549..5af89b9 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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" } }