re PR fortran/49638 ([OOP] length parameter is ignored when overriding type bound character functions with constant length.)
2011-08-07 Janus Weil <janus@gcc.gnu.org> PR fortran/49638 * dependency.h (gfc_is_same_range,gfc_are_identical_variables): Remove two prototypes. * dependency.c (gfc_are_identical_variables,are_identical_variables): Renamed the former to the latter and made static. (gfc_dep_compare_expr): Renamed 'gfc_are_identical_variables', handle commutativity of multiplication. (gfc_is_same_range,is_same_range): Renamed the former to the latter, made static and removed argument 'def'. (check_section_vs_section): Renamed 'gfc_is_same_range'. * gfortran.h (gfc_check_typebound_override): New prototype. * interface.c (gfc_check_typebound_override): Moved here from ... * resolve.c (check_typebound_override): ... here (and renamed). (resolve_typebound_procedure): Renamed 'check_typebound_override'. From-SVN: r177545
This commit is contained in:
parent
f446d60e81
commit
99fc1b90cd
|
@ -1,3 +1,20 @@
|
|||
2011-08-07 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/49638
|
||||
* dependency.h (gfc_is_same_range,gfc_are_identical_variables): Remove
|
||||
two prototypes.
|
||||
* dependency.c (gfc_are_identical_variables,are_identical_variables):
|
||||
Renamed the former to the latter and made static.
|
||||
(gfc_dep_compare_expr): Renamed 'gfc_are_identical_variables', handle
|
||||
commutativity of multiplication.
|
||||
(gfc_is_same_range,is_same_range): Renamed the former to the latter,
|
||||
made static and removed argument 'def'.
|
||||
(check_section_vs_section): Renamed 'gfc_is_same_range'.
|
||||
* gfortran.h (gfc_check_typebound_override): New prototype.
|
||||
* interface.c (gfc_check_typebound_override): Moved here from ...
|
||||
* resolve.c (check_typebound_override): ... here (and renamed).
|
||||
(resolve_typebound_procedure): Renamed 'check_typebound_override'.
|
||||
|
||||
2011-08-06 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/50004
|
||||
|
|
|
@ -118,8 +118,8 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
|
|||
/* Return true for identical variables, checking for references if
|
||||
necessary. Calls identical_array_ref for checking array sections. */
|
||||
|
||||
bool
|
||||
gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
||||
static bool
|
||||
are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
||||
{
|
||||
gfc_ref *r1, *r2;
|
||||
|
||||
|
@ -169,7 +169,7 @@ gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
|||
break;
|
||||
|
||||
default:
|
||||
gfc_internal_error ("gfc_are_identical_variables: Bad type");
|
||||
gfc_internal_error ("are_identical_variables: Bad type");
|
||||
}
|
||||
r1 = r1->next;
|
||||
r2 = r2->next;
|
||||
|
@ -421,7 +421,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
|
|||
return 1;
|
||||
|
||||
case EXPR_VARIABLE:
|
||||
if (gfc_are_identical_variables (e1, e2))
|
||||
if (are_identical_variables (e1, e2))
|
||||
return 0;
|
||||
else
|
||||
return -2;
|
||||
|
@ -438,7 +438,12 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
|
|||
if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
|
||||
&& gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
|
||||
return 0;
|
||||
/* TODO Handle commutative binary operators here? */
|
||||
else if (e1->value.op.op == INTRINSIC_TIMES
|
||||
&& gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
|
||||
&& gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
|
||||
/* Commutativity of multiplication. */
|
||||
return 0;
|
||||
|
||||
return -2;
|
||||
|
||||
case EXPR_FUNCTION:
|
||||
|
@ -451,11 +456,11 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
|
|||
}
|
||||
|
||||
|
||||
/* Returns 1 if the two ranges are the same, 0 if they are not, and def
|
||||
if the results are indeterminate. N is the dimension to compare. */
|
||||
/* Returns 1 if the two ranges are the same and 0 if they are not (or if the
|
||||
results are indeterminate). 'n' is the dimension to compare. */
|
||||
|
||||
int
|
||||
gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
|
||||
static int
|
||||
is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
|
||||
{
|
||||
gfc_expr *e1;
|
||||
gfc_expr *e2;
|
||||
|
@ -472,25 +477,19 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
|
|||
if (e1 && !e2)
|
||||
{
|
||||
i = gfc_expr_is_one (e1, -1);
|
||||
if (i == -1)
|
||||
return def;
|
||||
else if (i == 0)
|
||||
if (i == -1 || i == 0)
|
||||
return 0;
|
||||
}
|
||||
else if (e2 && !e1)
|
||||
{
|
||||
i = gfc_expr_is_one (e2, -1);
|
||||
if (i == -1)
|
||||
return def;
|
||||
else if (i == 0)
|
||||
if (i == -1 || i == 0)
|
||||
return 0;
|
||||
}
|
||||
else if (e1 && e2)
|
||||
{
|
||||
i = gfc_dep_compare_expr (e1, e2);
|
||||
if (i == -2)
|
||||
return def;
|
||||
else if (i != 0)
|
||||
if (i != 0)
|
||||
return 0;
|
||||
}
|
||||
/* The strides match. */
|
||||
|
@ -509,12 +508,10 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
|
|||
|
||||
/* Check we have values for both. */
|
||||
if (!(e1 && e2))
|
||||
return def;
|
||||
return 0;
|
||||
|
||||
i = gfc_dep_compare_expr (e1, e2);
|
||||
if (i == -2)
|
||||
return def;
|
||||
else if (i != 0)
|
||||
if (i != 0)
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
@ -532,12 +529,10 @@ gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
|
|||
|
||||
/* Check we have values for both. */
|
||||
if (!(e1 && e2))
|
||||
return def;
|
||||
return 0;
|
||||
|
||||
i = gfc_dep_compare_expr (e1, e2);
|
||||
if (i == -2)
|
||||
return def;
|
||||
else if (i != 0)
|
||||
if (i != 0)
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
@ -1091,7 +1086,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
|
|||
int start_comparison;
|
||||
|
||||
/* If they are the same range, return without more ado. */
|
||||
if (gfc_is_same_range (l_ar, r_ar, n, 0))
|
||||
if (is_same_range (l_ar, r_ar, n))
|
||||
return GFC_DEP_EQUAL;
|
||||
|
||||
l_start = l_ar->start[n];
|
||||
|
|
|
@ -37,11 +37,7 @@ gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
|
|||
int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
|
||||
gfc_actual_arglist *, gfc_dep_check);
|
||||
int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
|
||||
int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
|
||||
int gfc_expr_is_one (gfc_expr *, int);
|
||||
|
||||
int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
|
||||
int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
|
||||
|
||||
bool gfc_are_identical_variables (gfc_expr *, gfc_expr *);
|
||||
|
||||
|
|
|
@ -2840,6 +2840,7 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
|
|||
bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
|
||||
int gfc_has_vector_subscript (gfc_expr*);
|
||||
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
|
||||
gfc_try gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
|
||||
|
||||
/* io.c */
|
||||
extern gfc_st_label format_asterisk;
|
||||
|
|
|
@ -3466,3 +3466,197 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
|
|||
free (p);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Check that it is ok for the typebound procedure proc to override the
|
||||
procedure old. */
|
||||
|
||||
gfc_try
|
||||
gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
||||
{
|
||||
locus where;
|
||||
const gfc_symbol* proc_target;
|
||||
const gfc_symbol* old_target;
|
||||
unsigned proc_pass_arg, old_pass_arg, argpos;
|
||||
gfc_formal_arglist* proc_formal;
|
||||
gfc_formal_arglist* old_formal;
|
||||
|
||||
/* This procedure should only be called for non-GENERIC proc. */
|
||||
gcc_assert (!proc->n.tb->is_generic);
|
||||
|
||||
/* If the overwritten procedure is GENERIC, this is an error. */
|
||||
if (old->n.tb->is_generic)
|
||||
{
|
||||
gfc_error ("Can't overwrite GENERIC '%s' at %L",
|
||||
old->name, &proc->n.tb->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
where = proc->n.tb->where;
|
||||
proc_target = proc->n.tb->u.specific->n.sym;
|
||||
old_target = old->n.tb->u.specific->n.sym;
|
||||
|
||||
/* Check that overridden binding is not NON_OVERRIDABLE. */
|
||||
if (old->n.tb->non_overridable)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a procedure binding declared"
|
||||
" NON_OVERRIDABLE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
|
||||
if (!old->n.tb->deferred && proc->n.tb->deferred)
|
||||
{
|
||||
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
|
||||
" non-DEFERRED binding", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is PURE, the overriding must be, too. */
|
||||
if (old_target->attr.pure && !proc_target->attr.pure)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
|
||||
proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
|
||||
is not, the overriding must not be either. */
|
||||
if (old_target->attr.elemental && !proc_target->attr.elemental)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
|
||||
" ELEMENTAL", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
if (!old_target->attr.elemental && proc_target->attr.elemental)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
|
||||
" be ELEMENTAL, either", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
|
||||
SUBROUTINE. */
|
||||
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
|
||||
" SUBROUTINE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is a FUNCTION, the overriding must also be a
|
||||
FUNCTION and have the same characteristics. */
|
||||
if (old_target->attr.function)
|
||||
{
|
||||
if (!proc_target->attr.function)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
|
||||
" FUNCTION", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* FIXME: Do more comprehensive checking (including, for instance, the
|
||||
rank and array-shape). */
|
||||
gcc_assert (proc_target->result && old_target->result);
|
||||
if (!gfc_compare_types (&proc_target->result->ts,
|
||||
&old_target->result->ts))
|
||||
{
|
||||
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
|
||||
" matching result types", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
/* If the overridden binding is PUBLIC, the overriding one must not be
|
||||
PRIVATE. */
|
||||
if (old->n.tb->access == ACCESS_PUBLIC
|
||||
&& proc->n.tb->access == ACCESS_PRIVATE)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
|
||||
" PRIVATE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Compare the formal argument lists of both procedures. This is also abused
|
||||
to find the position of the passed-object dummy arguments of both
|
||||
bindings as at least the overridden one might not yet be resolved and we
|
||||
need those positions in the check below. */
|
||||
proc_pass_arg = old_pass_arg = 0;
|
||||
if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
|
||||
proc_pass_arg = 1;
|
||||
if (!old->n.tb->nopass && !old->n.tb->pass_arg)
|
||||
old_pass_arg = 1;
|
||||
argpos = 1;
|
||||
for (proc_formal = proc_target->formal, old_formal = old_target->formal;
|
||||
proc_formal && old_formal;
|
||||
proc_formal = proc_formal->next, old_formal = old_formal->next)
|
||||
{
|
||||
if (proc->n.tb->pass_arg
|
||||
&& !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
|
||||
proc_pass_arg = argpos;
|
||||
if (old->n.tb->pass_arg
|
||||
&& !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
|
||||
old_pass_arg = argpos;
|
||||
|
||||
/* Check that the names correspond. */
|
||||
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
|
||||
{
|
||||
gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
|
||||
" to match the corresponding argument of the overridden"
|
||||
" procedure", proc_formal->sym->name, proc->name, &where,
|
||||
old_formal->sym->name);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Check that the types correspond if neither is the passed-object
|
||||
argument. */
|
||||
/* FIXME: Do more comprehensive testing here. */
|
||||
if (proc_pass_arg != argpos && old_pass_arg != argpos
|
||||
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
|
||||
{
|
||||
gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
|
||||
"in respect to the overridden procedure",
|
||||
proc_formal->sym->name, proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
++argpos;
|
||||
}
|
||||
if (proc_formal || old_formal)
|
||||
{
|
||||
gfc_error ("'%s' at %L must have the same number of formal arguments as"
|
||||
" the overridden procedure", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is NOPASS, the overriding one must also be
|
||||
NOPASS. */
|
||||
if (old->n.tb->nopass && !proc->n.tb->nopass)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
|
||||
" NOPASS", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is PASS(x), the overriding one must also be
|
||||
PASS and the passed-object dummy arguments must correspond. */
|
||||
if (!old->n.tb->nopass)
|
||||
{
|
||||
if (proc->n.tb->nopass)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
|
||||
" PASS", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (proc_pass_arg != old_pass_arg)
|
||||
{
|
||||
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
|
||||
" the same position as the passed-object dummy argument of"
|
||||
" the overridden procedure", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
|
|
@ -10672,200 +10672,6 @@ error:
|
|||
}
|
||||
|
||||
|
||||
/* Check that it is ok for the typebound procedure proc to override the
|
||||
procedure old. */
|
||||
|
||||
static gfc_try
|
||||
check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
||||
{
|
||||
locus where;
|
||||
const gfc_symbol* proc_target;
|
||||
const gfc_symbol* old_target;
|
||||
unsigned proc_pass_arg, old_pass_arg, argpos;
|
||||
gfc_formal_arglist* proc_formal;
|
||||
gfc_formal_arglist* old_formal;
|
||||
|
||||
/* This procedure should only be called for non-GENERIC proc. */
|
||||
gcc_assert (!proc->n.tb->is_generic);
|
||||
|
||||
/* If the overwritten procedure is GENERIC, this is an error. */
|
||||
if (old->n.tb->is_generic)
|
||||
{
|
||||
gfc_error ("Can't overwrite GENERIC '%s' at %L",
|
||||
old->name, &proc->n.tb->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
where = proc->n.tb->where;
|
||||
proc_target = proc->n.tb->u.specific->n.sym;
|
||||
old_target = old->n.tb->u.specific->n.sym;
|
||||
|
||||
/* Check that overridden binding is not NON_OVERRIDABLE. */
|
||||
if (old->n.tb->non_overridable)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a procedure binding declared"
|
||||
" NON_OVERRIDABLE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
|
||||
if (!old->n.tb->deferred && proc->n.tb->deferred)
|
||||
{
|
||||
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
|
||||
" non-DEFERRED binding", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is PURE, the overriding must be, too. */
|
||||
if (old_target->attr.pure && !proc_target->attr.pure)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
|
||||
proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
|
||||
is not, the overriding must not be either. */
|
||||
if (old_target->attr.elemental && !proc_target->attr.elemental)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
|
||||
" ELEMENTAL", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
if (!old_target->attr.elemental && proc_target->attr.elemental)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
|
||||
" be ELEMENTAL, either", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is a SUBROUTINE, the overriding must also be a
|
||||
SUBROUTINE. */
|
||||
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
|
||||
" SUBROUTINE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is a FUNCTION, the overriding must also be a
|
||||
FUNCTION and have the same characteristics. */
|
||||
if (old_target->attr.function)
|
||||
{
|
||||
if (!proc_target->attr.function)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
|
||||
" FUNCTION", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* FIXME: Do more comprehensive checking (including, for instance, the
|
||||
rank and array-shape). */
|
||||
gcc_assert (proc_target->result && old_target->result);
|
||||
if (!gfc_compare_types (&proc_target->result->ts,
|
||||
&old_target->result->ts))
|
||||
{
|
||||
gfc_error ("'%s' at %L and the overridden FUNCTION should have"
|
||||
" matching result types", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
/* If the overridden binding is PUBLIC, the overriding one must not be
|
||||
PRIVATE. */
|
||||
if (old->n.tb->access == ACCESS_PUBLIC
|
||||
&& proc->n.tb->access == ACCESS_PRIVATE)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
|
||||
" PRIVATE", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Compare the formal argument lists of both procedures. This is also abused
|
||||
to find the position of the passed-object dummy arguments of both
|
||||
bindings as at least the overridden one might not yet be resolved and we
|
||||
need those positions in the check below. */
|
||||
proc_pass_arg = old_pass_arg = 0;
|
||||
if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
|
||||
proc_pass_arg = 1;
|
||||
if (!old->n.tb->nopass && !old->n.tb->pass_arg)
|
||||
old_pass_arg = 1;
|
||||
argpos = 1;
|
||||
for (proc_formal = proc_target->formal, old_formal = old_target->formal;
|
||||
proc_formal && old_formal;
|
||||
proc_formal = proc_formal->next, old_formal = old_formal->next)
|
||||
{
|
||||
if (proc->n.tb->pass_arg
|
||||
&& !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
|
||||
proc_pass_arg = argpos;
|
||||
if (old->n.tb->pass_arg
|
||||
&& !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
|
||||
old_pass_arg = argpos;
|
||||
|
||||
/* Check that the names correspond. */
|
||||
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
|
||||
{
|
||||
gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
|
||||
" to match the corresponding argument of the overridden"
|
||||
" procedure", proc_formal->sym->name, proc->name, &where,
|
||||
old_formal->sym->name);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* Check that the types correspond if neither is the passed-object
|
||||
argument. */
|
||||
/* FIXME: Do more comprehensive testing here. */
|
||||
if (proc_pass_arg != argpos && old_pass_arg != argpos
|
||||
&& !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
|
||||
{
|
||||
gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
|
||||
"in respect to the overridden procedure",
|
||||
proc_formal->sym->name, proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
++argpos;
|
||||
}
|
||||
if (proc_formal || old_formal)
|
||||
{
|
||||
gfc_error ("'%s' at %L must have the same number of formal arguments as"
|
||||
" the overridden procedure", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is NOPASS, the overriding one must also be
|
||||
NOPASS. */
|
||||
if (old->n.tb->nopass && !proc->n.tb->nopass)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
|
||||
" NOPASS", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
/* If the overridden binding is PASS(x), the overriding one must also be
|
||||
PASS and the passed-object dummy arguments must correspond. */
|
||||
if (!old->n.tb->nopass)
|
||||
{
|
||||
if (proc->n.tb->nopass)
|
||||
{
|
||||
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
|
||||
" PASS", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (proc_pass_arg != old_pass_arg)
|
||||
{
|
||||
gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
|
||||
" the same position as the passed-object dummy argument of"
|
||||
" the overridden procedure", proc->name, &where);
|
||||
return FAILURE;
|
||||
}
|
||||
}
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
|
||||
|
||||
static gfc_try
|
||||
|
@ -11327,12 +11133,15 @@ resolve_typebound_procedure (gfc_symtree* stree)
|
|||
overridden = gfc_find_typebound_proc (super_type, NULL,
|
||||
stree->name, true, NULL);
|
||||
|
||||
if (overridden && overridden->n.tb)
|
||||
if (overridden)
|
||||
{
|
||||
if (overridden->n.tb)
|
||||
stree->n.tb->overridden = overridden->n.tb;
|
||||
|
||||
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
|
||||
if (gfc_check_typebound_override (stree, overridden) == FAILURE)
|
||||
goto error;
|
||||
}
|
||||
}
|
||||
|
||||
/* See if there's a name collision with a component directly in this type. */
|
||||
for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
|
||||
|
|
Loading…
Reference in New Issue