From 6f3ab30d8b7bfa0ab2e5a370f1196602960c271c Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Fri, 22 Jun 2012 23:05:51 +0200 Subject: [PATCH] re PR fortran/47710 ([OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS) 2012-06-22 Janus Weil PR fortran/47710 PR fortran/53328 * interface.c (count_types_test, generic_correspondence, gfc_compare_interfaces): Ignore PASS arguments. (check_interface1, compare_parameter): Pass NULL arguments to gfc_compare_interfaces. * gfortran.h (gfc_compare_interfaces): Modified prototype. * expr.c (gfc_check_pointer_assign): Pass NULL arguments to gfc_compare_interfaces. * resolve.c (resolve_structure_cons): Ditto. (check_generic_tbp_ambiguity): Determine PASS arguments and pass them to gfc_compare_interfaces. 2012-06-22 Janus Weil PR fortran/47710 PR fortran/53328 * gfortran.dg/typebound_generic_12.f03: New. * gfortran.dg/typebound_generic_13.f03: New. From-SVN: r188902 --- gcc/fortran/ChangeLog | 15 +++++ gcc/fortran/expr.c | 2 +- gcc/fortran/gfortran.h | 2 +- gcc/fortran/interface.c | 65 ++++++++++++------- gcc/fortran/resolve.c | 20 ++++-- gcc/testsuite/ChangeLog | 7 ++ .../gfortran.dg/typebound_generic_12.f03 | 26 ++++++++ .../gfortran.dg/typebound_generic_13.f03 | 28 ++++++++ 8 files changed, 135 insertions(+), 30 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_generic_12.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_generic_13.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f3265721de8..a804e263ef2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2012-06-22 Janus Weil + + PR fortran/47710 + PR fortran/53328 + * interface.c (count_types_test, generic_correspondence, + gfc_compare_interfaces): Ignore PASS arguments. + (check_interface1, compare_parameter): Pass NULL arguments to + gfc_compare_interfaces. + * gfortran.h (gfc_compare_interfaces): Modified prototype. + * expr.c (gfc_check_pointer_assign): Pass NULL arguments to + gfc_compare_interfaces. + * resolve.c (resolve_structure_cons): Ditto. + (check_generic_tbp_ambiguity): Determine PASS arguments and pass them + to gfc_compare_interfaces. + 2012-06-21 Janne Blomqvist PR fortran/39654 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 4765afa367f..0b38cacad94 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3498,7 +3498,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1, - err, sizeof(err))) + err, sizeof(err), NULL, NULL)) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 759074aa01a..43904e956a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2842,7 +2842,7 @@ void gfc_free_interface (gfc_interface *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, - char *, int); + char *, int, const char *, const char *); void gfc_check_interfaces (gfc_namespace *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 95439c118e4..7a63f696f54 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -826,12 +826,13 @@ bad_repl: a given type/rank in f1 and seeing if there are less then that number of those arguments in f2 (including optional arguments). Since this test is asymmetric, it has to be called twice to make it - symmetric. Returns nonzero if the argument lists are incompatible - by this test. This subroutine implements rule 1 of section - 14.1.2.3 in the Fortran 95 standard. */ + symmetric. Returns nonzero if the argument lists are incompatible + by this test. This subroutine implements rule 1 of section F03:16.2.3. + 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ static int -count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) +count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, + const char *p1, const char *p2) { int rc, ac1, ac2, i, j, k, n1; gfc_formal_arglist *f; @@ -868,14 +869,17 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) if (arg[i].flag != -1) continue; - if (arg[i].sym && arg[i].sym->attr.optional) - continue; /* Skip optional arguments. */ + if (arg[i].sym && (arg[i].sym->attr.optional + || (p1 && strcmp (arg[i].sym->name, p1) == 0))) + continue; /* Skip OPTIONAL and PASS arguments. */ arg[i].flag = k; - /* Find other nonoptional arguments of the same type/rank. */ + /* Find other non-optional, non-pass arguments of the same type/rank. */ for (j = i + 1; j < n1; j++) - if ((arg[j].sym == NULL || !arg[j].sym->attr.optional) + if ((arg[j].sym == NULL + || !(arg[j].sym->attr.optional + || (p1 && strcmp (arg[j].sym->name, p1) == 0))) && (compare_type_rank_if (arg[i].sym, arg[j].sym) || compare_type_rank_if (arg[j].sym, arg[i].sym))) arg[j].flag = k; @@ -897,13 +901,14 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) if (arg[j].flag == k) ac1++; - /* Count the number of arguments in f2 with that type, including - those that are optional. */ + /* Count the number of non-pass arguments in f2 with that type, + including those that are optional. */ ac2 = 0; for (f = f2; f; f = f->next) - if (compare_type_rank_if (arg[i].sym, f->sym) - || compare_type_rank_if (f->sym, arg[i].sym)) + if ((!p2 || strcmp (f->sym->name, p2) != 0) + && (compare_type_rank_if (arg[i].sym, f->sym) + || compare_type_rank_if (f->sym, arg[i].sym))) ac2++; if (ac1 > ac2) @@ -921,9 +926,10 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) } -/* Perform the correspondence test in rule 2 of section 14.1.2.3. - Returns zero if no argument is found that satisfies rule 2, nonzero - otherwise. +/* Perform the correspondence test in rule 3 of section F03:16.2.3. + Returns zero if no argument is found that satisfies rule 3, nonzero + otherwise. 'p1' and 'p2' are the PASS arguments of both procedures + (if applicable). This test is also not symmetric in f1 and f2 and must be called twice. This test finds problems caused by sorting the actual @@ -942,7 +948,8 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2) At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ static int -generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) +generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, + const char *p1, const char *p2) { gfc_formal_arglist *f2_save, *g; gfc_symbol *sym; @@ -954,6 +961,11 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) if (f1->sym->attr.optional) goto next; + if (p1 && strcmp (f1->sym->name, p1) == 0) + f1 = f1->next; + if (f2 && p2 && strcmp (f2->sym->name, p2) == 0) + f2 = f2->next; + if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) || compare_type_rank (f2->sym, f1->sym))) goto next; @@ -962,7 +974,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) the current non-match. */ for (g = f1; g; g = g->next) { - if (g->sym->attr.optional) + if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0)) continue; sym = find_keyword_arg (g->sym->name, f2_save); @@ -971,7 +983,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) } next: - f1 = f1->next; + if (f1 != NULL) + f1 = f1->next; if (f2 != NULL) f2 = f2->next; } @@ -1129,12 +1142,14 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, We return nonzero if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. 'strict_flag' specifies whether all the characteristics are - required to match, which is not the case for ambiguity checks.*/ + required to match, which is not the case for ambiguity checks. + 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ int gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, int generic_flag, int strict_flag, - char *errmsg, int err_len) + char *errmsg, int err_len, + const char *p1, const char *p2) { gfc_formal_arglist *f1, *f2; @@ -1200,9 +1215,11 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, if (generic_flag) { - if (count_types_test (f1, f2) || count_types_test (f2, f1)) + if (count_types_test (f1, f2, p1, p2) + || count_types_test (f2, f1, p2, p1)) return 0; - if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1)) + if (generic_correspondence (f1, f2, p1, p2) + || generic_correspondence (f2, f1, p2, p1)) return 0; } else @@ -1349,7 +1366,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, if (p->sym->attr.flavor != FL_DERIVED && q->sym->attr.flavor != FL_DERIVED && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, - generic_flag, 0, NULL, 0)) + generic_flag, 0, NULL, 0, NULL, NULL)) { if (referenced) gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", @@ -1676,7 +1693,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, - sizeof(err))) + sizeof(err), NULL, NULL)) { if (where) gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s", diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d09cb11bd3f..4595f76c9a4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1152,7 +1152,7 @@ resolve_structure_cons (gfc_expr *expr, int init) } if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, - err, sizeof (err))) + err, sizeof (err), NULL, NULL)) { gfc_error ("Interface mismatch for procedure-pointer component " "'%s' in structure constructor at %L: %s", @@ -11020,8 +11020,8 @@ static gfc_try check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, const char* generic_name, locus where) { - gfc_symbol* sym1; - gfc_symbol* sym2; + gfc_symbol *sym1, *sym2; + const char *pass1, *pass2; gcc_assert (t1->specific && t2->specific); gcc_assert (!t1->specific->is_generic); @@ -11045,8 +11045,20 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } /* Compare the interfaces. */ + if (t1->specific->nopass) + pass1 = NULL; + else if (t1->specific->pass_arg) + pass1 = t1->specific->pass_arg; + else + pass1 = t1->specific->u.specific->n.sym->formal->sym->name; + if (t2->specific->nopass) + pass2 = NULL; + else if (t2->specific->pass_arg) + pass2 = t2->specific->pass_arg; + else + pass2 = t2->specific->u.specific->n.sym->formal->sym->name; if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, - NULL, 0)) + NULL, 0, pass1, pass2)) { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fe323456838..0e67aa0f590 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2012-06-22 Janus Weil + + PR fortran/47710 + PR fortran/53328 + * gfortran.dg/typebound_generic_12.f03: New. + * gfortran.dg/typebound_generic_13.f03: New. + 2012-06-22 Eric Botcazou * gnat.dg/lto15.ad[sb]: New test. diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_12.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_12.f03 new file mode 100644 index 00000000000..061a41a07f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_generic_12.f03 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 53328: [OOP] Ambiguous check for type-bound GENERIC shall ignore PASSed arguments +! +! Contributed by Salvatore Filippone + +module m + type t + contains + procedure, pass(this) :: sub1 + procedure, pass(this) :: sub2 + generic :: gen => sub1, sub2 ! { dg-error "are ambiguous" } + end type t +contains + subroutine sub1 (x, this) + integer :: i + class(t) :: this + end subroutine sub1 + + subroutine sub2 (this, y) + integer :: i + class(t) :: this + end subroutine sub2 +end module m + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_13.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_13.f03 new file mode 100644 index 00000000000..c2116e965a8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_generic_13.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 47710: [OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS +! +! Contributed by Janus Weil + +module m + + type base_t + contains + procedure, nopass :: baseproc_nopass => baseproc1 + procedure, pass :: baseproc_pass => baseproc2 + generic :: some_proc => baseproc_pass, baseproc_nopass ! { dg-error "are ambiguous" } + end type + +contains + + subroutine baseproc1 (this) + class(base_t) :: this + end subroutine + + subroutine baseproc2 (this, that) + class(base_t) :: this, that + end subroutine + +end module + +! { dg-final { cleanup-modules "m" } } -- 2.30.2