git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Janus Weil 2012-06-22 23:05:51 +02:00
parent 42533d77ac
commit 6f3ab30d8b
8 changed files with 135 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
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

2
gcc/fortran/expr.c
View File

@ -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);

2
gcc/fortran/gfortran.h
View File

@ -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 *);

65
gcc/fortran/interface.c
View File

@ -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",

20
gcc/fortran/resolve.c
View File

@ -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);

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
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.

26
gcc/testsuite/gfortran.dg/typebound_generic_12.f03 Normal file
View File

@ -0,0 +1,26 @@
! { 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" } }

28
gcc/testsuite/gfortran.dg/typebound_generic_13.f03 Normal file
View File

@ -0,0 +1,28 @@
! { 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" } }