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>
|
2011-08-06 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/50004
|
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
|
/* Return true for identical variables, checking for references if
|
||||||
necessary. Calls identical_array_ref for checking array sections. */
|
necessary. Calls identical_array_ref for checking array sections. */
|
||||||
|
|
||||||
bool
|
static bool
|
||||||
gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
||||||
{
|
{
|
||||||
gfc_ref *r1, *r2;
|
gfc_ref *r1, *r2;
|
||||||
|
|
||||||
|
@ -169,7 +169,7 @@ gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
|
||||||
break;
|
break;
|
||||||
|
|
||||||
default:
|
default:
|
||||||
gfc_internal_error ("gfc_are_identical_variables: Bad type");
|
gfc_internal_error ("are_identical_variables: Bad type");
|
||||||
}
|
}
|
||||||
r1 = r1->next;
|
r1 = r1->next;
|
||||||
r2 = r2->next;
|
r2 = r2->next;
|
||||||
|
@ -421,7 +421,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
|
||||||
return 1;
|
return 1;
|
||||||
|
|
||||||
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
||||||
if (gfc_are_identical_variables (e1, e2))
|
if (are_identical_variables (e1, e2))
|
||||||
return 0;
|
return 0;
|
||||||
else
|
else
|
||||||
return -2;
|
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
|
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)
|
&& gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
|
||||||
return 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;
|
return -2;
|
||||||
|
|
||||||
case EXPR_FUNCTION:
|
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
|
/* Returns 1 if the two ranges are the same and 0 if they are not (or if the
|
||||||
if the results are indeterminate. N is the dimension to compare. */
|
results are indeterminate). 'n' is the dimension to compare. */
|
||||||
|
|
||||||
int
|
static int
|
||||||
gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
|
is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
|
||||||
{
|
{
|
||||||
gfc_expr *e1;
|
gfc_expr *e1;
|
||||||
gfc_expr *e2;
|
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)
|
if (e1 && !e2)
|
||||||
{
|
{
|
||||||
i = gfc_expr_is_one (e1, -1);
|
i = gfc_expr_is_one (e1, -1);
|
||||||
if (i == -1)
|
if (i == -1 || i == 0)
|
||||||
return def;
|
|
||||||
else if (i == 0)
|
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
else if (e2 && !e1)
|
else if (e2 && !e1)
|
||||||
{
|
{
|
||||||
i = gfc_expr_is_one (e2, -1);
|
i = gfc_expr_is_one (e2, -1);
|
||||||
if (i == -1)
|
if (i == -1 || i == 0)
|
||||||
return def;
|
|
||||||
else if (i == 0)
|
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
else if (e1 && e2)
|
else if (e1 && e2)
|
||||||
{
|
{
|
||||||
i = gfc_dep_compare_expr (e1, e2);
|
i = gfc_dep_compare_expr (e1, e2);
|
||||||
if (i == -2)
|
if (i != 0)
|
||||||
return def;
|
|
||||||
else if (i != 0)
|
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
/* The strides match. */
|
/* 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. */
|
/* Check we have values for both. */
|
||||||
if (!(e1 && e2))
|
if (!(e1 && e2))
|
||||||
return def;
|
return 0;
|
||||||
|
|
||||||
i = gfc_dep_compare_expr (e1, e2);
|
i = gfc_dep_compare_expr (e1, e2);
|
||||||
if (i == -2)
|
if (i != 0)
|
||||||
return def;
|
|
||||||
else if (i != 0)
|
|
||||||
return 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. */
|
/* Check we have values for both. */
|
||||||
if (!(e1 && e2))
|
if (!(e1 && e2))
|
||||||
return def;
|
return 0;
|
||||||
|
|
||||||
i = gfc_dep_compare_expr (e1, e2);
|
i = gfc_dep_compare_expr (e1, e2);
|
||||||
if (i == -2)
|
if (i != 0)
|
||||||
return def;
|
|
||||||
else if (i != 0)
|
|
||||||
return 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;
|
int start_comparison;
|
||||||
|
|
||||||
/* If they are the same range, return without more ado. */
|
/* 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;
|
return GFC_DEP_EQUAL;
|
||||||
|
|
||||||
l_start = l_ar->start[n];
|
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 *,
|
int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
|
||||||
gfc_actual_arglist *, gfc_dep_check);
|
gfc_actual_arglist *, gfc_dep_check);
|
||||||
int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
|
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_expr_is_one (gfc_expr *, int);
|
||||||
|
|
||||||
int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
|
int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
|
||||||
int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
|
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);
|
bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
|
||||||
int gfc_has_vector_subscript (gfc_expr*);
|
int gfc_has_vector_subscript (gfc_expr*);
|
||||||
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
|
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
|
||||||
|
gfc_try gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
|
||||||
|
|
||||||
/* io.c */
|
/* io.c */
|
||||||
extern gfc_st_label format_asterisk;
|
extern gfc_st_label format_asterisk;
|
||||||
|
|
|
@ -3466,3 +3466,197 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
|
||||||
free (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. */
|
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
|
||||||
|
|
||||||
static gfc_try
|
static gfc_try
|
||||||
|
@ -11327,11 +11133,14 @@ resolve_typebound_procedure (gfc_symtree* stree)
|
||||||
overridden = gfc_find_typebound_proc (super_type, NULL,
|
overridden = gfc_find_typebound_proc (super_type, NULL,
|
||||||
stree->name, true, NULL);
|
stree->name, true, NULL);
|
||||||
|
|
||||||
if (overridden && overridden->n.tb)
|
if (overridden)
|
||||||
stree->n.tb->overridden = overridden->n.tb;
|
{
|
||||||
|
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;
|
goto error;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/* See if there's a name collision with a component directly in this type. */
|
/* See if there's a name collision with a component directly in this type. */
|
||||||
|
|
Loading…
Reference in New Issue