Skip to content

R
riscv-gcc-1
Commit 6f3ab30d by Janus Weil
Options

re PR fortran/47710 ([OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS) 

2012-06-22  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>

	PR fortran/47710
	PR fortran/53328
	* gfortran.dg/typebound_generic_12.f03: New.
	* gfortran.dg/typebound_generic_13.f03: New.

From-SVN: r188902
parent 42533d77
Showing with 135 additions and 30 deletions
gcc/fortran/ChangeLog
2012-06-22 Janus Weil <janus@gcc.gnu.org>
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 <jb@gcc.gnu.org>
PR fortran/39654
......
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);
......
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 *);
......
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",
......
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);
......
gcc/testsuite/ChangeLog
2012-06-22 Janus Weil <janus@gcc.gnu.org>
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 <ebotcazou@adacore.com>
* gnat.dg/lto15.ad[sb]: New test.
......
gcc/testsuite/gfortran.dg/typebound_generic_12.f03 0 → 100644
! { dg-do compile }
!
! PR 53328: [OOP] Ambiguous check for type-bound GENERIC shall ignore PASSed arguments
!
! Contributed by Salvatore Filippone <filippone.salvatore@gmail.com>
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" } }
gcc/testsuite/gfortran.dg/typebound_generic_13.f03 0 → 100644
! { dg-do compile }
!
! PR 47710: [OOP] Improve ambiguity check for GENERIC TBP w/ PASS and NOPASS
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment