From 517d78beb772c6a1a11e4952e1d51e49113e79dc Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 11 Jan 2015 23:00:06 +0100 Subject: [PATCH] re PR fortran/63733 ([OOP] wrong resolution for OPERATOR generics) 2015-01-11 Janus Weil PR fortran/63733 * interface.c (gfc_extend_expr): Look for type-bound operators before non-typebound ones. 2015-01-11 Janus Weil PR fortran/63733 * gfortran.dg/typebound_operator_20.f90: New. From-SVN: r219440 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/interface.c | 93 +++++++++---------- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/typebound_operator_20.f90 | 53 +++++++++++ 4 files changed, 108 insertions(+), 49 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_20.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6f2e549c1b6..5af89b9752e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-01-11 Janus Weil + + PR fortran/63733 + * interface.c (gfc_extend_expr): Look for type-bound operators before + non-typebound ones. + 2015-01-11 Janus Weil PR fortran/58023 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index ca9751fa096..dd3ad2a0cd2 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 4f729fd9569..b3b6b59091d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-01-11 Janus Weil + + PR fortran/63733 + * gfortran.dg/typebound_operator_20.f90: New. + 2015-01-11 Janus Weil PR fortran/58023 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 00000000000..26c49a188eb --- /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 +! Slightly modified by Salvatore Filippone +! Further modified by Janus Weil + +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" } } -- 2.30.2