diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a804e263ef2..bbd0b50a904 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2012-06-27 Janus Weil + + PR fortran/41951 + PR fortran/49591 + * interface.c (check_new_interface): Rename, add 'loc' argument, + make non-static. + (gfc_add_interface): Rename 'check_new_interface' + * gfortran.h (gfc_check_new_interface): Add prototype. + * resolve.c (resolve_typebound_intrinsic_op): Add typebound operator + targets to non-typebound operator list. + 2012-06-22 Janus Weil PR fortran/47710 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 43904e956a0..caa23bd6388 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2851,6 +2851,7 @@ gfc_symbol *gfc_search_interface (gfc_interface *, int, match gfc_extend_expr (gfc_expr *); void gfc_free_formal_arglist (gfc_formal_arglist *); gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *); +gfc_try gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus); gfc_try gfc_add_interface (gfc_symbol *); gfc_interface *gfc_current_interface_head (void); void gfc_set_current_interface_head (gfc_interface *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7a63f696f54..34e1ad7f88b 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3551,8 +3551,8 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) the given interface list. Ambiguity isn't checked yet since module procedures can be present without interfaces. */ -static gfc_try -check_new_interface (gfc_interface *base, gfc_symbol *new_sym) +gfc_try +gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) { gfc_interface *ip; @@ -3560,8 +3560,8 @@ check_new_interface (gfc_interface *base, gfc_symbol *new_sym) { if (ip->sym == new_sym) { - gfc_error ("Entity '%s' at %C is already present in the interface", - new_sym->name); + gfc_error ("Entity '%s' at %L is already present in the interface", + new_sym->name, &loc); return FAILURE; } } @@ -3591,48 +3591,61 @@ gfc_add_interface (gfc_symbol *new_sym) { case INTRINSIC_EQ: case INTRINSIC_EQ_OS: - if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; case INTRINSIC_NE: case INTRINSIC_NE_OS: - if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; case INTRINSIC_GT: case INTRINSIC_GT_OS: - if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_GT], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; case INTRINSIC_GE: case INTRINSIC_GE_OS: - if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_GE], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; case INTRINSIC_LT: case INTRINSIC_LT_OS: - if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_LT], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; case INTRINSIC_LE: case INTRINSIC_LE_OS: - if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE || - check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[INTRINSIC_LE], new_sym, + gfc_current_locus) == FAILURE + || gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; break; default: - if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE) + if (gfc_check_new_interface (ns->op[current_interface.op], new_sym, + gfc_current_locus) == FAILURE) return FAILURE; } @@ -3646,7 +3659,8 @@ gfc_add_interface (gfc_symbol *new_sym) if (sym == NULL) continue; - if (check_new_interface (sym->generic, new_sym) == FAILURE) + if (gfc_check_new_interface (sym->generic, new_sym, gfc_current_locus) + == FAILURE) return FAILURE; } @@ -3654,8 +3668,8 @@ gfc_add_interface (gfc_symbol *new_sym) break; case INTERFACE_USER_OP: - if (check_new_interface (current_interface.uop->op, new_sym) - == FAILURE) + if (gfc_check_new_interface (current_interface.uop->op, new_sym, + gfc_current_locus) == FAILURE) return FAILURE; head = ¤t_interface.uop->op; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4595f76c9a4..0434e0804c7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11264,6 +11264,22 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, if (!gfc_check_operator_interface (target_proc, op, p->where)) goto error; + + /* Add target to non-typebound operator list. */ + if (!target->specific->deferred && !derived->attr.use_assoc + && p->access != ACCESS_PRIVATE) + { + gfc_interface *head, *intr; + if (gfc_check_new_interface (derived->ns->op[op], target_proc, + p->where) == FAILURE) + return FAILURE; + head = derived->ns->op[op]; + intr = gfc_get_interface (); + intr->sym = target_proc; + intr->where = p->where; + intr->next = head; + derived->ns->op[op] = intr; + } } return SUCCESS; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0c85963d358..3f2a06fafe4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-06-27 Janus Weil + + PR fortran/41951 + PR fortran/49591 + * gfortran.dg/typebound_operator_16.f03: New. + 2012-06-27 Jakub Jelinek * gcc.target/i386/sse4_1-pmuldq.c (TEST): Initialize diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_16.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_16.f03 new file mode 100644 index 00000000000..eff43ebe53b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_16.f03 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR 49591: [OOP] Multiple identical specific procedures in type-bound operator not detected +! +! This is interpretation request F03/0018: +! http://www.j3-fortran.org/doc/meeting/195/11-214.txt +! +! Contributed by Tobias Burnus + +module M1 + type T + integer x + contains + procedure :: MyAdd_t => myadd + generic :: operator(+) => myAdd_t + end type T + type X + real q + contains + procedure, pass(b) :: MyAdd_x => myadd + generic :: operator(+) => myAdd_x ! { dg-error "is already present in the interface" } + end type X +contains + integer function MyAdd ( A, B ) + class(t), intent(in) :: A + class(x), intent(in) :: B + myadd = a%x + b%q + end function MyAdd +end module + +module M2 + interface operator(+) + procedure MyAdd + end interface + type T + integer x + contains + procedure :: MyAdd_t => myadd + generic :: operator(+) => myAdd_t ! { dg-error "is already present in the interface" } + end type T +contains + integer function MyAdd ( A, B ) + class(t), intent(in) :: A + real, intent(in) :: B + myadd = a%x + b + end function MyAdd +end module + +! { dg-final { cleanup-modules "M1 M2" } }