===================================================================
@@ -3466,3 +3466,208 @@ 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' (F08:4.5.7.3). */
+
+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 array shape). */
+ gcc_assert (proc_target->result && old_target->result);
+ if (!compare_type_rank (proc_target->result, old_target->result))
+ {
+ gfc_error ("'%s' at %L and the overridden FUNCTION should have"
+ " matching result types and ranks", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* Check string length. */
+ if (proc_target->result->ts.type == BT_CHARACTER
+ && proc_target->result->ts.u.cl && old_target->result->ts.u.cl
+ && gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
+ old_target->result->ts.u.cl->length,
+ true) != 0)
+ {
+ gfc_error ("Character length mismatch between '%s' at '%L' "
+ "and overridden FUNCTION", 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;
+}
===================================================================
@@ -3763,7 +3763,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop
if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
depends[n] = 2;
else if (! gfc_is_same_range (&lref->u.ar,
- &rref->u.ar, dim, 0))
+ &rref->u.ar, dim, false))
depends[n] = 1;
}
===================================================================
@@ -498,7 +498,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, in
/* If the start and end expressions are equal, the length is one. */
if (ref->u.ss.end
- && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
+ && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end, false) == 0)
tmp = build_int_cst (gfc_charlen_type_node, 1);
else
{
===================================================================
@@ -2840,6 +2840,7 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglis
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;
@@ -2891,8 +2892,8 @@ void gfc_global_used (gfc_gsymbol *, locus *);
gfc_namespace* gfc_build_block_ns (gfc_namespace *);
/* dependency.c */
-int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
-int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
+int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool, bool);
+int gfc_dep_compare_expr (gfc_expr *, gfc_expr *, bool);
/* check.c */
gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
===================================================================
@@ -2552,7 +2552,7 @@ check_forall_dependencies (gfc_code *c, stmtblock_
break;
if (rref && lref
- && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
+ && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start, false) < 0)
{
forall_make_variable_temp (c, pre, post);
need_temp = 0;
===================================================================
@@ -371,8 +371,8 @@ cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
newvar = NULL;
for (j=0; j<i; j++)
{
- if (gfc_dep_compare_functions(*(expr_array[i]),
- *(expr_array[j]), true) == 0)
+ if (gfc_dep_compare_functions (*(expr_array[i]), *(expr_array[j]),
+ true, false) == 0)
{
if (newvar == NULL)
newvar = create_var (*(expr_array[i]));
@@ -681,7 +681,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op
|| (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
&& op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
{
- eq = gfc_dep_compare_expr (op1, op2);
+ eq = gfc_dep_compare_expr (op1, op2, false);
if (eq == -2)
{
/* Replace A // B < A // C with B < C, and A // B < C // B
@@ -695,7 +695,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op
gfc_expr *op1_right = op1->value.op.op2;
gfc_expr *op2_right = op2->value.op.op2;
- if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
+ if (gfc_dep_compare_expr (op1_left, op2_left, false) == 0)
{
/* Watch out for 'A ' // x vs. 'A' // x. */
@@ -722,7 +722,7 @@ optimize_comparison (gfc_expr *e, gfc_intrinsic_op
return true;
}
}
- if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
+ if (gfc_dep_compare_expr (op1_right, op2_right, false) == 0)
{
free (op1_right);
free (op2_right);
===================================================================
@@ -2585,7 +2585,8 @@ is_scalar_expr_ptr (gfc_expr *expr)
{
case REF_SUBSTRING:
if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
- || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
+ || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end,
+ false) != 0)
retval = FAILURE;
break;
@@ -7139,7 +7140,7 @@ resolve_allocate_deallocate (gfc_code *code, const
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
if (gfc_dep_compare_expr (par->start[0],
- qar->start[0]) != 0)
+ qar->start[0], false) != 0)
break;
}
}
@@ -10672,200 +10673,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 +11134,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. */
===================================================================
@@ -668,7 +668,7 @@ gfc_var_strlen (const gfc_expr *a)
end_a = mpz_get_si (ra->u.ss.end->value.integer);
return end_a - start_a + 1;
}
- else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+ else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end, false) == 0)
return 1;
else
return -1;
===================================================================
@@ -53,7 +53,7 @@ gfc_dependency;
/* Forward declarations */
static gfc_dependency check_section_vs_section (gfc_array_ref *,
- gfc_array_ref *, int);
+ gfc_array_ref *, int, bool);
/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
def if the value could not be determined. */
@@ -76,7 +76,7 @@ gfc_expr_is_one (gfc_expr *expr, int def)
gfc_dep_compare_expr if necessary for comparing array indices. */
static bool
-identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
+identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2, bool var_name_only)
{
int i;
@@ -94,7 +94,7 @@ static bool
|| a2->dimen_type[i] != DIMEN_RANGE)
return false;
- if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
+ if (check_section_vs_section (a1, a2, i, var_name_only) != GFC_DEP_EQUAL)
return false;
}
return true;
@@ -105,7 +105,7 @@ static bool
gcc_assert (a1->dimen == a2->dimen);
for (i = 0; i < a1->dimen; i++)
{
- if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
+ if (gfc_dep_compare_expr (a1->start[i], a2->start[i], var_name_only) != 0)
return false;
}
return true;
@@ -115,17 +115,28 @@ static bool
-/* Return true for identical variables, checking for references if
- necessary. Calls identical_array_ref for checking array sections. */
+/* Return true for identical variables, checking for references if necessary.
+ Calls identical_array_ref for checking array sections. If the flag
+ 'var_name_only' is set, then dummy arguments are only checked for equal
+ names, not for symbol equality. */
-bool
-gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+static bool
+are_identical_variables (gfc_expr *e1, gfc_expr *e2, bool var_name_only)
{
gfc_ref *r1, *r2;
+
+ if (var_name_only
+ && e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
+ {
+ if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
+ return false;
+ }
+ else
+ {
+ if (e1->symtree->n.sym != e2->symtree->n.sym)
+ return false;
+ }
- if (e1->symtree->n.sym != e2->symtree->n.sym)
- return false;
-
/* Volatile variables should never compare equal to themselves. */
if (e1->symtree->n.sym->attr.volatile_)
@@ -152,7 +163,7 @@ static bool
{
case REF_ARRAY:
- if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
+ if (!identical_array_ref (&r1->u.ar, &r2->u.ar, var_name_only))
return false;
break;
@@ -163,13 +174,13 @@ static bool
break;
case REF_SUBSTRING:
- if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0
- || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
+ if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start, var_name_only) != 0
+ || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end, var_name_only) != 0)
return false;
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;
@@ -181,7 +192,8 @@ static bool
impure_ok is false, only return 0 for pure functions. */
int
-gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
+gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2,
+ bool impure_ok, bool var_name_only)
{
gfc_actual_arglist *args1;
@@ -208,7 +220,7 @@ int
return -2;
if (args1->expr != NULL && args2->expr != NULL
- && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+ && gfc_dep_compare_expr (args1->expr, args2->expr, var_name_only) != 0)
return -2;
args1 = args1->next;
@@ -221,10 +233,12 @@ int
}
/* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
- and -2 if the relationship could not be determined. */
+ and -2 if the relationship could not be determined. If 'var_name_only' is
+ true, we only check the variable names for equality, not the symbols
+ themselves. */
int
-gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
+gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2, bool var_name_only)
{
gfc_actual_arglist *args1;
gfc_actual_arglist *args2;
@@ -258,31 +272,31 @@ int
if (n1 != NULL)
{
if (n2 != NULL)
- return gfc_dep_compare_expr (n1, n2);
+ return gfc_dep_compare_expr (n1, n2, var_name_only);
else
- return gfc_dep_compare_expr (n1, e2);
+ return gfc_dep_compare_expr (n1, e2, var_name_only);
}
else
{
if (n2 != NULL)
- return gfc_dep_compare_expr (e1, n2);
+ return gfc_dep_compare_expr (e1, n2, var_name_only);
}
if (e1->expr_type == EXPR_OP
&& (e1->value.op.op == INTRINSIC_UPLUS
|| e1->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1->value.op.op1, e2);
+ return gfc_dep_compare_expr (e1->value.op.op1, e2, var_name_only);
if (e2->expr_type == EXPR_OP
&& (e2->value.op.op == INTRINSIC_UPLUS
|| e2->value.op.op == INTRINSIC_PARENTHESES))
- return gfc_dep_compare_expr (e1, e2->value.op.op1);
+ return gfc_dep_compare_expr (e1, e2->value.op.op1, var_name_only);
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
/* Compare X+C vs. X. */
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
&& e1->value.op.op2->ts.type == BT_INTEGER
- && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+ && gfc_dep_compare_expr (e1->value.op.op1, e2, var_name_only) == 0)
return mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P+Q vs. R+S. */
@@ -290,8 +304,8 @@ int
{
int l, r;
- l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
- r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+ l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1, var_name_only);
+ r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2, var_name_only);
if (l == 0 && r == 0)
return 0;
if (l == 0 && r != -2)
@@ -303,8 +317,8 @@ int
if (l == -1 && r == -1)
return -1;
- l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
- r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
+ l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2, var_name_only);
+ r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1, var_name_only);
if (l == 0 && r == 0)
return 0;
if (l == 0 && r != -2)
@@ -323,7 +337,7 @@ int
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
- && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+ && gfc_dep_compare_expr (e1, e2->value.op.op1, var_name_only) == 0)
return -mpz_sgn (e2->value.op.op2->value.integer);
}
@@ -332,7 +346,7 @@ int
{
if (e1->value.op.op2->expr_type == EXPR_CONSTANT
&& e1->value.op.op2->ts.type == BT_INTEGER
- && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+ && gfc_dep_compare_expr (e1->value.op.op1, e2, var_name_only) == 0)
return -mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P-Q vs. R-S. */
@@ -340,8 +354,8 @@ int
{
int l, r;
- l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
- r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+ l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1, var_name_only);
+ r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2, var_name_only);
if (l == 0 && r == 0)
return 0;
if (l != -2 && r == 0)
@@ -362,8 +376,8 @@ int
{
int l, r;
- l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
- r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+ l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1, var_name_only);
+ r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2, var_name_only);
if (l == -2)
return -2;
@@ -396,7 +410,7 @@ int
{
if (e2->value.op.op2->expr_type == EXPR_CONSTANT
&& e2->value.op.op2->ts.type == BT_INTEGER
- && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+ && gfc_dep_compare_expr (e1, e2->value.op.op1, var_name_only) == 0)
return mpz_sgn (e2->value.op.op2->value.integer);
}
@@ -421,7 +435,7 @@ int
return 1;
case EXPR_VARIABLE:
- if (gfc_are_identical_variables (e1, e2))
+ if (are_identical_variables (e1, e2, var_name_only))
return 0;
else
return -2;
@@ -432,18 +446,22 @@ int
return -2;
if (e1->value.op.op2 == 0)
{
- i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+ i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1, var_name_only);
return i == 0 ? 0 : -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)
+ if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1, var_name_only) == 0
+ && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2, var_name_only) == 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, var_name_only) == 0
+ && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1, var_name_only) == 0)
+ /* Commutativity of multiplication. */
+ return 0;
+
return -2;
case EXPR_FUNCTION:
- return gfc_dep_compare_functions (e1, e2, false);
- break;
+ return gfc_dep_compare_functions (e1, e2, false, var_name_only);
default:
return -2;
@@ -451,11 +469,12 @@ int
}
-/* 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, bool var_name_only)
{
gfc_expr *e1;
gfc_expr *e2;
@@ -472,25 +491,19 @@ int
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)
+ i = gfc_dep_compare_expr (e1, e2, var_name_only);
+ if (i != 0)
return 0;
}
/* The strides match. */
@@ -509,12 +522,10 @@ int
/* 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)
+ i = gfc_dep_compare_expr (e1, e2, var_name_only);
+ if (i != 0)
return 0;
}
@@ -532,12 +543,10 @@ int
/* 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)
+ i = gfc_dep_compare_expr (e1, e2, var_name_only);
+ if (i != 0)
return 0;
}
@@ -1071,7 +1080,8 @@ gfc_check_dependency (gfc_expr *expr1, gfc_expr *e
/* Determines overlapping for two array sections. */
static gfc_dependency
-check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
+check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n,
+ bool var_name_only)
{
gfc_expr *l_start;
gfc_expr *l_end;
@@ -1091,7 +1101,7 @@ static gfc_dependency
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, var_name_only))
return GFC_DEP_EQUAL;
l_start = l_ar->start[n];
@@ -1123,7 +1133,7 @@ static gfc_dependency
&& l_stride->ts.type == BT_INTEGER)
l_dir = mpz_sgn (l_stride->value.integer);
else if (l_start && l_end)
- l_dir = gfc_dep_compare_expr (l_end, l_start);
+ l_dir = gfc_dep_compare_expr (l_end, l_start, var_name_only);
else
l_dir = -2;
@@ -1134,7 +1144,7 @@ static gfc_dependency
&& r_stride->ts.type == BT_INTEGER)
r_dir = mpz_sgn (r_stride->value.integer);
else if (r_start && r_end)
- r_dir = gfc_dep_compare_expr (r_end, r_start);
+ r_dir = gfc_dep_compare_expr (r_end, r_start, var_name_only);
else
r_dir = -2;
@@ -1152,10 +1162,11 @@ static gfc_dependency
one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
- r_stride ? r_stride : one_expr);
+ r_stride ? r_stride : one_expr,
+ var_name_only);
if (l_start && r_start)
- start_comparison = gfc_dep_compare_expr (l_start, r_start);
+ start_comparison = gfc_dep_compare_expr (l_start, r_start, var_name_only);
else
start_comparison = -2;
@@ -1196,13 +1207,13 @@ static gfc_dependency
}
/* Check whether the ranges are disjoint. */
- if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
+ if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower, var_name_only) == -1)
return GFC_DEP_NODEP;
- if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
+ if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower, var_name_only) == -1)
return GFC_DEP_NODEP;
/* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
- if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
+ if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start, var_name_only) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
@@ -1211,7 +1222,7 @@ static gfc_dependency
}
/* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
- if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
+ if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end, var_name_only) == 0)
{
if (l_dir == 1 && r_dir == -1)
return GFC_DEP_EQUAL;
@@ -1279,7 +1290,7 @@ static gfc_dependency
of low, which is always at least a forward dependence. */
if (r_dir == 1
- && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
+ && gfc_dep_compare_expr (l_start, l_ar->as->lower[n], var_name_only) == 0)
return GFC_DEP_FORWARD;
}
}
@@ -1294,7 +1305,7 @@ static gfc_dependency
of high, which is always at least a forward dependence. */
if (r_dir == -1
- && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
+ && gfc_dep_compare_expr (l_start, l_ar->as->upper[n], var_name_only) == 0)
return GFC_DEP_FORWARD;
}
}
@@ -1359,19 +1370,19 @@ gfc_check_element_vs_section( gfc_ref *lref, gfc_r
if (s == 1)
{
/* Check for elem < lower. */
- if (start && gfc_dep_compare_expr (elem, start) == -1)
+ if (start && gfc_dep_compare_expr (elem, start, false) == -1)
return GFC_DEP_NODEP;
/* Check for elem > upper. */
- if (end && gfc_dep_compare_expr (elem, end) == 1)
+ if (end && gfc_dep_compare_expr (elem, end, false) == 1)
return GFC_DEP_NODEP;
if (start && end)
{
- s = gfc_dep_compare_expr (start, end);
+ s = gfc_dep_compare_expr (start, end, false);
/* Check for an empty range. */
if (s == 1)
return GFC_DEP_NODEP;
- if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+ if (s == 0 && gfc_dep_compare_expr (elem, start, false) == 0)
return GFC_DEP_EQUAL;
}
}
@@ -1379,19 +1390,19 @@ gfc_check_element_vs_section( gfc_ref *lref, gfc_r
else if (s == -1)
{
/* Check for elem > upper. */
- if (end && gfc_dep_compare_expr (elem, start) == 1)
+ if (end && gfc_dep_compare_expr (elem, start, false) == 1)
return GFC_DEP_NODEP;
/* Check for elem < lower. */
- if (start && gfc_dep_compare_expr (elem, end) == -1)
+ if (start && gfc_dep_compare_expr (elem, end, false) == -1)
return GFC_DEP_NODEP;
if (start && end)
{
- s = gfc_dep_compare_expr (start, end);
+ s = gfc_dep_compare_expr (start, end, false);
/* Check for an empty range. */
if (s == -1)
return GFC_DEP_NODEP;
- if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+ if (s == 0 && gfc_dep_compare_expr (elem, start, false) == 0)
return GFC_DEP_EQUAL;
}
}
@@ -1400,33 +1411,33 @@ gfc_check_element_vs_section( gfc_ref *lref, gfc_r
{
if (!start || !end)
return GFC_DEP_OVERLAP;
- s = gfc_dep_compare_expr (start, end);
+ s = gfc_dep_compare_expr (start, end, false);
if (s == -2)
return GFC_DEP_OVERLAP;
/* Assume positive stride. */
if (s == -1)
{
/* Check for elem < lower. */
- if (gfc_dep_compare_expr (elem, start) == -1)
+ if (gfc_dep_compare_expr (elem, start, false) == -1)
return GFC_DEP_NODEP;
/* Check for elem > upper. */
- if (gfc_dep_compare_expr (elem, end) == 1)
+ if (gfc_dep_compare_expr (elem, end, false) == 1)
return GFC_DEP_NODEP;
}
/* Assume negative stride. */
else if (s == 1)
{
/* Check for elem > upper. */
- if (gfc_dep_compare_expr (elem, start) == 1)
+ if (gfc_dep_compare_expr (elem, start, false) == 1)
return GFC_DEP_NODEP;
/* Check for elem < lower. */
- if (gfc_dep_compare_expr (elem, end) == -1)
+ if (gfc_dep_compare_expr (elem, end, false) == -1)
return GFC_DEP_NODEP;
}
/* Equal bounds. */
else if (s == 0)
{
- s = gfc_dep_compare_expr (elem, start);
+ s = gfc_dep_compare_expr (elem, start, false);
if (s == 0)
return GFC_DEP_EQUAL;
if (s == 1 || s == -1)
@@ -1532,7 +1543,7 @@ gfc_check_element_vs_element (gfc_ref *lref, gfc_r
r_ar = rref->u.ar;
l_start = l_ar.start[n] ;
r_start = r_ar.start[n] ;
- i = gfc_dep_compare_expr (r_start, l_start);
+ i = gfc_dep_compare_expr (r_start, l_start, false);
if (i == 0)
return GFC_DEP_EQUAL;
@@ -1607,10 +1618,10 @@ gfc_full_array_ref_p (gfc_ref *ref, bool *contiguo
|| !ref->u.ar.as->lower[i]
|| !ref->u.ar.as->upper[i]
|| gfc_dep_compare_expr (ref->u.ar.as->lower[i],
- ref->u.ar.as->upper[i])
+ ref->u.ar.as->upper[i], false)
|| !ref->u.ar.start[i]
|| gfc_dep_compare_expr (ref->u.ar.start[i],
- ref->u.ar.as->lower[i]))
+ ref->u.ar.as->lower[i], false))
return false;
else
continue;
@@ -1621,14 +1632,14 @@ gfc_full_array_ref_p (gfc_ref *ref, bool *contiguo
&& (!ref->u.ar.as
|| !ref->u.ar.as->lower[i]
|| gfc_dep_compare_expr (ref->u.ar.start[i],
- ref->u.ar.as->lower[i])))
+ ref->u.ar.as->lower[i], false)))
lbound_OK = false;
/* Check the upper bound. */
if (ref->u.ar.end[i]
&& (!ref->u.ar.as
|| !ref->u.ar.as->upper[i]
|| gfc_dep_compare_expr (ref->u.ar.end[i],
- ref->u.ar.as->upper[i])))
+ ref->u.ar.as->upper[i], false)))
ubound_OK = false;
/* Check the stride. */
if (ref->u.ar.stride[i]
@@ -1682,10 +1693,10 @@ ref_same_as_full_array (gfc_ref *full_ref, gfc_ref
|| !full_ref->u.ar.as->lower[i]
|| !full_ref->u.ar.as->upper[i]
|| gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
- full_ref->u.ar.as->upper[i])
+ full_ref->u.ar.as->upper[i], false)
|| !ref->u.ar.start[i]
|| gfc_dep_compare_expr (ref->u.ar.start[i],
- full_ref->u.ar.as->lower[i]))
+ full_ref->u.ar.as->lower[i], false))
return false;
}
@@ -1701,14 +1712,14 @@ ref_same_as_full_array (gfc_ref *full_ref, gfc_ref
&& (ref->u.ar.as
&& full_ref->u.ar.as->lower[i]
&& gfc_dep_compare_expr (ref->u.ar.start[i],
- full_ref->u.ar.as->lower[i]) == 0))
+ full_ref->u.ar.as->lower[i], false) == 0))
upper_or_lower = true;
/* Check the upper bound. */
if (ref->u.ar.end[i]
&& (ref->u.ar.as
&& full_ref->u.ar.as->upper[i]
&& gfc_dep_compare_expr (ref->u.ar.end[i],
- full_ref->u.ar.as->upper[i]) == 0))
+ full_ref->u.ar.as->upper[i], false) == 0))
upper_or_lower = true;
if (!upper_or_lower)
return false;
@@ -1787,7 +1798,7 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gf
if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
&& rref->u.ar.dimen_type[n] == DIMEN_RANGE)
- this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n);
+ this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n, false);
else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
&& rref->u.ar.dimen_type[n] == DIMEN_RANGE)
this_dep = gfc_check_element_vs_section (lref, rref, n);
===================================================================
@@ -37,11 +37,8 @@ gfc_expr *gfc_get_noncopying_intrinsic_argument (g
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_is_same_range (gfc_array_ref *, gfc_array_ref *, int, bool);*/
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 *);
-