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;
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;
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)
}
-/* 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
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;
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;
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);
}
next:
- f1 = f1->next;
+ if (f1 != NULL)
+ f1 = f1->next;
if (f2 != NULL)
f2 = f2->next;
}
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;
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
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",
}
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",
}
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",
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);
}
/* 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);
projects / gcc.git / commitdiff