static void
show_constructor (gfc_constructor_base base)
{
gfc_constructor *c;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
if (c->iterator == NULL)
show_expr (c->expr);
else
{
fputc ('(', dumpfile);
show_expr (c->expr);
fputc (' ', dumpfile);
show_expr (c->iterator->var);
fputc ('=', dumpfile);
show_expr (c->iterator->start);
fputc (',', dumpfile);
show_expr (c->iterator->end);
fputc (',', dumpfile);
show_expr (c->iterator->step);
fputc (')', dumpfile);
}
if (gfc_constructor_next (c) != NULL)
fputs (" , ", dumpfile);
}
}
static void
formalize_init_expr (gfc_expr *expr)
{
expr_t type;
gfc_constructor *c;
if (expr == NULL)
return;
type = expr->expr_type;
switch (type)
{
case EXPR_ARRAY:
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c))
formalize_init_expr (c->expr);
break;
case EXPR_STRUCTURE:
formalize_structure_cons (expr);
break;
default:
break;
}
}
static void
formalize_structure_cons (gfc_expr *expr)
{
gfc_constructor_base base = NULL;
gfc_constructor *cur;
gfc_component *order;
/* Constructor is already formalized. */
cur = gfc_constructor_first (expr->value.constructor);
if (!cur || cur->n.component == NULL)
return;
for (order = expr->ts.u.derived->components; order; order = order->next)
{
cur = find_con_by_component (order, expr->value.constructor);
if (cur)
gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
else
gfc_constructor_append_expr (&base, NULL, NULL);
}
/* For all what it's worth, one would expect
gfc_constructor_free (expr->value.constructor);
here. However, if the constructor is actually free'd,
hell breaks loose in the testsuite?! */
expr->value.constructor = base;
}
size_t
gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
unsigned char *chk, size_t length)
{
size_t len = 0;
gfc_constructor * c;
switch (e->expr_type)
{
case EXPR_CONSTANT:
case EXPR_STRUCTURE:
len = expr_to_char (e, &data[0], &chk[0], length);
break;
case EXPR_ARRAY:
for (c = gfc_constructor_first (e->value.constructor);
c; c = gfc_constructor_next (c))
{
size_t elt_size = gfc_target_expr_size (c->expr);
if (c->offset)
len = elt_size * (size_t)mpz_get_si (c->offset);
len = len + gfc_merge_initializers (ts, c->expr, &data[len],
&chk[len], length - len);
}
break;
default:
return 0;
}
return len;
}
static int
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
{
gfc_constructor *c;
gfc_component *cmp;
int ptr;
tree type;
type = gfc_typenode_for_spec (&source->ts);
for (c = gfc_constructor_first (source->value.constructor),
cmp = source->ts.u.derived->components;
c;
c = gfc_constructor_next (c), cmp = cmp->next)
{
gcc_assert (cmp);
if (!c->expr)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
if (c->expr->expr_type == EXPR_NULL)
memset (&buffer[ptr], 0,
int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
else
gfc_target_encode_expr (c->expr, &buffer[ptr],
buffer_size - ptr);
}
return int_size_in_bytes (type);
}
static size_t
size_array (gfc_expr *e)
{
mpz_t array_size;
gfc_constructor *c = gfc_constructor_first (e->value.constructor);
size_t elt_size = gfc_target_expr_size (c->expr);
gfc_array_size (e, &array_size);
return (size_t)mpz_get_ui (array_size) * elt_size;
}
static gfc_constructor *
find_con_by_component (gfc_component *com, gfc_constructor_base base)
{
gfc_constructor *c;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
if (com == c->n.component)
return c;
return NULL;
}
static size_t
expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
{
int i;
int ptr;
gfc_constructor *c;
gfc_component *cmp;
unsigned char *buffer;
if (e == NULL)
return 0;
/* Take a derived type, one component at a time, using the offsets from the backend
declaration. */
if (e->ts.type == BT_DERIVED)
{
for (c = gfc_constructor_first (e->value.constructor),
cmp = e->ts.u.derived->components;
c; c = gfc_constructor_next (c), cmp = cmp->next)
{
gcc_assert (cmp && cmp->backend_decl);
if (!c->expr)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
}
return len;
}
/* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
to the target, in a buffer and check off the initialized part of the buffer. */
len = gfc_target_expr_size (e);
buffer = (unsigned char*)alloca (len);
len = gfc_target_encode_expr (e, buffer, len);
for (i = 0; i < (int)len; i++)
{
if (chk[i] && (buffer[i] != data[i]))
{
gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
"at %L", &e->where);
return 0;
}
chk[i] = 0xFF;
}
memcpy (data, buffer, len);
return len;
}
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 bool
contains_forall_index_p (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_constructor *c;
gfc_ref *ref;
int i;
if (!expr)
return false;
switch (expr->expr_type)
{
case EXPR_VARIABLE:
if (expr->symtree->n.sym->forall_index)
return true;
break;
case EXPR_OP:
if (contains_forall_index_p (expr->value.op.op1)
|| contains_forall_index_p (expr->value.op.op2))
return true;
break;
case EXPR_FUNCTION:
for (arg = expr->value.function.actual; arg; arg = arg->next)
if (contains_forall_index_p (arg->expr))
return true;
break;
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
for (c = gfc_constructor_first (expr->value.constructor);
c; gfc_constructor_next (c))
if (contains_forall_index_p (c->expr))
return true;
break;
default:
gcc_unreachable ();
}
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
if (contains_forall_index_p (ref->u.ar.start[i])
|| contains_forall_index_p (ref->u.ar.end[i])
|| contains_forall_index_p (ref->u.ar.stride[i]))
return true;
break;
case REF_COMPONENT:
break;
case REF_SUBSTRING:
if (contains_forall_index_p (ref->u.ss.start)
|| contains_forall_index_p (ref->u.ss.end))
return true;
break;
default:
gcc_unreachable ();
}
return false;
}
