Hi all,
this patch fixes a wrong-code regression related to operators, by
making sure that we look for typebound operators first, before looking
for non-typebound ones. (Note: Each typebound operator is also added
to the list of non-typebound ones, for reasons of diagnostics.)
Regtested on x86_64-unknown-linux-gnu. Ok for trunk? 4.9/4.8?
Cheers,
Janus
2015-01-11 Janus Weil <ja...@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 <ja...@gcc.gnu.org>
PR fortran/63733
* gfortran.dg/typebound_operator_20.f90: New.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 219429)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -3706,6 +3706,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;
@@ -3722,8 +3724,50 @@ 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)
{
uop = gfc_find_uop (e->value.op.uop->name, ns);
@@ -3772,58 +3816,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;
}
! { 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 <amar...@cimne.upc.edu>
! Slightly modified by Salvatore Filippone <sfilipp...@uniroma2.it>
! Further modified by Janus Weil <ja...@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
