static int
gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
gfc_expr * expr)
{
gcc_assert (var->expr_type == EXPR_VARIABLE);
gcc_assert (var->rank > 0);
switch (expr->expr_type)
{
case EXPR_VARIABLE:
return (gfc_ref_needs_temporary_p (expr->ref)
|| gfc_check_dependency (var, expr, 1));
case EXPR_ARRAY:
return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
{
expr = gfc_get_noncopying_intrinsic_argument (expr);
return gfc_check_argument_var_dependency (var, intent, expr);
}
return 0;
default:
return 0;
}
}
int
gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
{
gfc_actual_arglist *actual;
gfc_constructor *c;
int n;
gcc_assert (expr1->expr_type == EXPR_VARIABLE);
switch (expr2->expr_type)
{
case EXPR_OP:
n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
if (n)
return n;
if (expr2->value.op.op2)
return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
return 0;
case EXPR_VARIABLE:
/* The interesting cases are when the symbols don't match. */
if (expr1->symtree->n.sym != expr2->symtree->n.sym)
{
gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
/* Return 1 if expr1 and expr2 are equivalenced arrays. */
if (gfc_are_equivalenced_arrays (expr1, expr2))
return 1;
/* Symbols can only alias if they have the same type. */
if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
{
if (ts1->type != ts2->type || ts1->kind != ts2->kind)
return 0;
}
/* If either variable is a pointer, assume the worst. */
/* TODO: -fassume-no-pointer-aliasing */
if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
{
if (check_data_pointer_types (expr1, expr2)
&& check_data_pointer_types (expr2, expr1))
return 0;
return 1;
}
else
{
gfc_symbol *sym1 = expr1->symtree->n.sym;
gfc_symbol *sym2 = expr2->symtree->n.sym;
if (sym1->attr.target && sym2->attr.target
&& ((sym1->attr.dummy && !sym1->attr.contiguous
&& (!sym1->attr.dimension
|| sym2->as->type == AS_ASSUMED_SHAPE))
|| (sym2->attr.dummy && !sym2->attr.contiguous
&& (!sym2->attr.dimension
|| sym2->as->type == AS_ASSUMED_SHAPE))))
return 1;
}
/* Otherwise distinct symbols have no dependencies. */
return 0;
}
if (identical)
return 1;
/* Identical and disjoint ranges return 0,
overlapping ranges return 1. */
if (expr1->ref && expr2->ref)
return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
return 1;
case EXPR_FUNCTION:
if (expr2->inline_noncopying_intrinsic)
identical = 1;
/* Remember possible differences between elemental and
transformational functions. All functions inside a FORALL
will be pure. */
for (actual = expr2->value.function.actual;
actual; actual = actual->next)
{
if (!actual->expr)
continue;
n = gfc_check_dependency (expr1, actual->expr, identical);
if (n)
return n;
}
return 0;
case EXPR_CONSTANT:
case EXPR_NULL:
return 0;
case EXPR_ARRAY:
/* Loop through the array constructor's elements. */
for (c = gfc_constructor_first (expr2->value.constructor);
c; c = gfc_constructor_next (c))
{
/* If this is an iterator, assume the worst. */
if (c->iterator)
return 1;
/* Avoid recursion in the common case. */
if (c->expr->expr_type == EXPR_CONSTANT)
continue;
if (gfc_check_dependency (expr1, c->expr, 1))
return 1;
}
return 0;
default:
return 1;
}
}
static int
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
gfc_expr *expr, gfc_dep_check elemental)
{
gfc_expr *arg;
gcc_assert (var->expr_type == EXPR_VARIABLE);
gcc_assert (var->rank > 0);
switch (expr->expr_type)
{
case EXPR_VARIABLE:
/* In case of elemental subroutines, there is no dependency
between two same-range array references. */
if (gfc_ref_needs_temporary_p (expr->ref)
|| gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
{
if (elemental == ELEM_DONT_CHECK_VARIABLE)
{
/* Too many false positive with pointers. */
if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
{
/* Elemental procedures forbid unspecified intents,
and we don't check dependencies for INTENT_IN args. */
gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
/* We are told not to check dependencies.
We do it, however, and issue a warning in case we find one.
If a dependency is found in the case
elemental == ELEM_CHECK_VARIABLE, we will generate
a temporary, so we don't need to bother the user. */
gfc_warning ("INTENT(%s) actual argument at %L might "
"interfere with actual argument at %L.",
intent == INTENT_OUT ? "OUT" : "INOUT",
&var->where, &expr->where);
}
return 0;
}
else
return 1;
}
return 0;
case EXPR_ARRAY:
return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
&& (arg = gfc_get_noncopying_intrinsic_argument (expr))
&& gfc_check_argument_var_dependency (var, intent, arg, elemental))
return 1;
if (elemental)
{
if ((expr->value.function.esym
&& expr->value.function.esym->attr.elemental)
|| (expr->value.function.isym
&& expr->value.function.isym->elemental))
return gfc_check_fncall_dependency (var, intent, NULL,
expr->value.function.actual,
ELEM_CHECK_VARIABLE);
}
return 0;
case EXPR_OP:
/* In case of non-elemental procedures, there is no need to catch
dependencies, as we will make a temporary anyway. */
if (elemental)
{
/* If the actual arg EXPR is an expression, we need to catch
a dependency between variables in EXPR and VAR,
an intent((IN)OUT) variable. */
if (expr->value.op.op1
&& gfc_check_argument_var_dependency (var, intent,
expr->value.op.op1,
ELEM_CHECK_VARIABLE))
return 1;
else if (expr->value.op.op2
&& gfc_check_argument_var_dependency (var, intent,
expr->value.op.op2,
ELEM_CHECK_VARIABLE))
return 1;
}
return 0;
default:
return 0;
}
}
int
gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars,
int nvars)
{
gfc_ref *ref;
int n;
gfc_actual_arglist *actual;
gcc_assert (expr1->expr_type == EXPR_VARIABLE);
/* TODO: -fassume-no-pointer-aliasing */
if (expr1->symtree->n.sym->attr.pointer)
return 1;
for (ref = expr1->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
return 1;
}
switch (expr2->expr_type)
{
case EXPR_OP:
n = gfc_check_dependency (expr1, expr2->op1, vars, nvars);
if (n)
return n;
if (expr2->op2)
return gfc_check_dependency (expr1, expr2->op2, vars, nvars);
return 0;
case EXPR_VARIABLE:
if (expr2->symtree->n.sym->attr.pointer)
return 1;
for (ref = expr2->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
return 1;
}
if (expr1->symtree->n.sym != expr2->symtree->n.sym)
return 0;
for (ref = expr2->ref; ref; ref = ref->next)
{
/* Identical ranges return 0, overlapping ranges return 1. */
if (ref->type == REF_ARRAY)
return 1;
}
return 1;
case EXPR_FUNCTION:
/* Remember possible differences between elemental and
transformational functions. All functions inside a FORALL
will be pure. */
for (actual = expr2->value.function.actual;
actual; actual = actual->next)
{
if (!actual->expr)
continue;
n = gfc_check_dependency (expr1, actual->expr, vars, nvars);
if (n)
return n;
}
return 0;
case EXPR_CONSTANT:
return 0;
case EXPR_ARRAY:
/* Probably ok in the majority of (constant) cases. */
return 1;
default:
return 1;
}
}
int
gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
{
gfc_actual_arglist *actual;
gfc_ref *ref;
gfc_expr *expr;
int n;
gcc_assert (dest->expr_type == EXPR_VARIABLE
&& fncall->expr_type == EXPR_FUNCTION);
gcc_assert (fncall->rank > 0);
for (actual = fncall->value.function.actual; actual; actual = actual->next)
{
expr = actual->expr;
/* Skip args which are not present. */
if (!expr)
continue;
/* Non-variable expressions will be allocated temporaries anyway. */
switch (expr->expr_type)
{
case EXPR_VARIABLE:
if (expr->rank > 1)
{
/* This is an array section. */
for (ref = expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
break;
}
gcc_assert (ref);
/* AR_FULL can't contain vector subscripts. */
if (ref->u.ar.type == AR_SECTION)
{
for (n = 0; n < ref->u.ar.dimen; n++)
{
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
break;
}
/* Vector subscript array sections will be copied to a
temporary. */
if (n != ref->u.ar.dimen)
continue;
}
}
if (gfc_check_dependency (dest, actual->expr, NULL, 0))
return 1;
break;
case EXPR_ARRAY:
if (gfc_check_dependency (dest, expr, NULL, 0))
return 1;
break;
default:
break;
}
}
return 0;
}
int
gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
{
gfc_ref *ref;
int n;
gfc_actual_arglist *actual;
gcc_assert (expr1->expr_type == EXPR_VARIABLE);
switch (expr2->expr_type)
{
case EXPR_OP:
n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
if (n)
return n;
if (expr2->value.op.op2)
return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
return 0;
case EXPR_VARIABLE:
/* The interesting cases are when the symbols don't match. */
if (expr1->symtree->n.sym != expr2->symtree->n.sym)
{
gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
/* Return 1 if expr1 and expr2 are equivalenced arrays. */
if (gfc_are_equivalenced_arrays (expr1, expr2))
return 1;
/* Symbols can only alias if they have the same type. */
if (ts1->type != BT_UNKNOWN
&& ts2->type != BT_UNKNOWN
&& ts1->type != BT_DERIVED
&& ts2->type != BT_DERIVED)
{
if (ts1->type != ts2->type
|| ts1->kind != ts2->kind)
return 0;
}
/* If either variable is a pointer, assume the worst. */
/* TODO: -fassume-no-pointer-aliasing */
if (expr1->symtree->n.sym->attr.pointer)
return 1;
for (ref = expr1->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
return 1;
if (expr2->symtree->n.sym->attr.pointer)
return 1;
for (ref = expr2->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
return 1;
/* Otherwise distinct symbols have no dependencies. */
return 0;
}
if (identical)
return 1;
/* Identical and disjoint ranges return 0,
overlapping ranges return 1. */
/* Return zero if we refer to the same full arrays. */
if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
return gfc_dep_resolver (expr1->ref, expr2->ref);
return 1;
case EXPR_FUNCTION:
if (expr2->inline_noncopying_intrinsic)
identical = 1;
/* Remember possible differences between elemental and
transformational functions. All functions inside a FORALL
will be pure. */
for (actual = expr2->value.function.actual;
actual; actual = actual->next)
{
if (!actual->expr)
continue;
n = gfc_check_dependency (expr1, actual->expr, identical);
if (n)
return n;
}
return 0;
case EXPR_CONSTANT:
case EXPR_NULL:
return 0;
case EXPR_ARRAY:
/* Probably ok in the majority of (constant) cases. */
return 1;
default:
return 1;
}
}
