+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
/* 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;
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;
return 1;
case EXPR_VARIABLE:
- if (gfc_are_identical_variables (e1, e2))
+ if (are_identical_variables (e1, e2))
return 0;
else
return -2;
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:
}
-/* 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;
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. */
/* 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;
}
/* 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;
}
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];
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 *);
-
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;
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;
+}
}
-/* 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
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. */
projects / gcc.git / commitdiff