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;
}
}
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 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;
}
bool
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
mpz_t *repeat)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr = NULL;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Break out of the loop if we find a substring. */
if (ref->type == REF_SUBSTRING)
{
/* A substring should always be the last subobject reference. */
gcc_assert (ref->next == NULL);
break;
}
/* Use the existing initializer expression if it exists. Otherwise
create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (ref->u.ar.as->rank == 0)
{
gcc_assert (ref->u.ar.as->corank > 0);
if (init == NULL)
free (expr);
continue;
}
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("%qs at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
goto abort;
}
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
/* Check the bounds. */
if (mpz_cmp_si (offset, 0) < 0)
{
gfc_error ("Data element below array lower bound at %L",
&lvalue->where);
goto abort;
}
else if (repeat != NULL
&& ref->u.ar.type != AR_ELEMENT)
{
mpz_t size, end;
gcc_assert (ref->u.ar.type == AR_FULL
&& ref->next == NULL);
mpz_init_set (end, offset);
mpz_add (end, end, *repeat);
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (end, size) > 0)
{
mpz_clear (size);
gfc_error ("Data element above array upper bound at %L",
&lvalue->where);
goto abort;
}
mpz_clear (size);
}
con = gfc_constructor_lookup (expr->value.constructor,
mpz_get_si (offset));
if (!con)
{
con = gfc_constructor_lookup_next (expr->value.constructor,
mpz_get_si (offset));
if (con != NULL && mpz_cmp (con->offset, end) >= 0)
con = NULL;
}
/* Overwriting an existing initializer is non-standard but
usually only provokes a warning from other compilers. */
if (con != NULL && con->expr != NULL)
{
/* Order in which the expressions arrive here depends on
whether they are from data statements or F95 style
declarations. Therefore, check which is the most
recent. */
gfc_expr *exprd;
exprd = (LOCATION_LINE (con->expr->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? con->expr : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of %qs at %L",
symbol->name, &exprd->where) == false)
return false;
}
while (con != NULL)
{
gfc_constructor *next_con = gfc_constructor_next (con);
if (mpz_cmp (con->offset, end) >= 0)
break;
if (mpz_cmp (con->offset, offset) < 0)
{
gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
mpz_sub (con->repeat, offset, con->offset);
}
else if (mpz_cmp_si (con->repeat, 1) > 0
&& mpz_get_si (con->offset)
+ mpz_get_si (con->repeat) > mpz_get_si (end))
{
int endi;
splay_tree_node node
= splay_tree_lookup (con->base,
mpz_get_si (con->offset));
gcc_assert (node
&& con == (gfc_constructor *) node->value
&& node->key == (splay_tree_key)
mpz_get_si (con->offset));
endi = mpz_get_si (con->offset)
+ mpz_get_si (con->repeat);
if (endi > mpz_get_si (end) + 1)
mpz_set_si (con->repeat, endi - mpz_get_si (end));
else
mpz_set_si (con->repeat, 1);
mpz_set (con->offset, end);
node->key = (splay_tree_key) mpz_get_si (end);
break;
}
else
gfc_constructor_remove (con);
con = next_con;
}
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &rvalue->where,
mpz_get_si (offset));
mpz_set (con->repeat, *repeat);
repeat = NULL;
mpz_clear (end);
break;
}
else
{
mpz_t size;
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (offset, size) >= 0)
{
mpz_clear (size);
gfc_error ("Data element above array upper bound at %L",
&lvalue->where);
goto abort;
}
mpz_clear (size);
}
}
con = gfc_constructor_lookup (expr->value.constructor,
mpz_get_si (offset));
if (!con)
{
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &rvalue->where,
mpz_get_si (offset));
}
else if (mpz_cmp_si (con->repeat, 1) > 0)
{
/* Need to split a range. */
if (mpz_cmp (con->offset, offset) < 0)
{
gfc_constructor *pred_con = con;
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &con->where,
mpz_get_si (offset));
con->expr = gfc_copy_expr (pred_con->expr);
mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
mpz_sub (con->repeat, con->repeat, offset);
mpz_sub (pred_con->repeat, offset, pred_con->offset);
}
if (mpz_cmp_si (con->repeat, 1) > 0)
{
gfc_constructor *succ_con;
succ_con
= gfc_constructor_insert_expr (&expr->value.constructor,
NULL, &con->where,
mpz_get_si (offset) + 1);
succ_con->expr = gfc_copy_expr (con->expr);
mpz_sub_ui (succ_con->repeat, con->repeat, 1);
mpz_set_si (con->repeat, 1);
}
}
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.u.derived = ref->u.c.sym;
}
else
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = find_con_by_component (ref->u.c.component,
expr->value.constructor);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_constructor_append_expr (&expr->value.constructor,
NULL, NULL);
con->n.component = ref->u.c.component;
}
break;
default:
gcc_unreachable ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
mpz_clear (offset);
gcc_assert (repeat == NULL);
if (ref || last_ts->type == BT_CHARACTER)
{
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
return false;
expr = create_character_initializer (init, last_ts, ref, rvalue);
}
else
{
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
if (init != NULL)
{
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of %qs at %L",
symbol->name, &expr->where) == false)
return false;
}
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
return true;
abort:
if (!init)
gfc_free_expr (expr);
mpz_clear (offset);
return false;
}
