OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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:
Janus Weil 2011-08-07 12:12:09 +02:00
parent f446d60e81
commit 99fc1b90cd
6 changed files with 241 additions and 229 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View File

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

49
gcc/fortran/dependency.c
View File

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

4
gcc/fortran/dependency.h
View File

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

1
gcc/fortran/gfortran.h
View File

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

194
gcc/fortran/interface.c
View File

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

205
gcc/fortran/resolve.c
View File

@ -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,11 +11133,14 @@ resolve_typebound_procedure (gfc_symtree* stree)
overridden = gfc_find_typebound_proc (super_type, NULL,
stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->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)
goto error;
if (gfc_check_typebound_override (stree, overridden) == FAILURE)
goto error;
}
}
/* See if there's a name collision with a component directly in this type. */