#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "toplev.h"
#include "gfortran.h"
#include "assert.h"
#include "trans.h"
static void formalize_init_expr (gfc_expr *);
static void
get_array_index (gfc_array_ref * ar, mpz_t * offset)
{
gfc_expr *e;
int i;
try re;
mpz_t delta;
mpz_t tmp;
mpz_init (tmp);
mpz_set_si (*offset, 0);
mpz_init_set_si (delta, 1);
for (i = 0; i < ar->dimen; i++)
{
e = gfc_copy_expr (ar->start[i]);
re = gfc_simplify_expr (e, 1);
if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
|| (gfc_is_constant_expr (ar->as->upper[i]) == 0)
|| (gfc_is_constant_expr (e) == 0))
gfc_error ("non-constant array in DATA statement %L.", &ar->where);
mpz_set (tmp, e->value.integer);
mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
mpz_clear (delta);
mpz_clear (tmp);
}
static gfc_constructor *
find_con_by_offset (mpz_t offset, gfc_constructor *con)
{
for (; con; con = con->next)
{
if (mpz_cmp (offset, con->n.offset) == 0)
return con;
}
return NULL;
}
static gfc_constructor *
find_con_by_component (gfc_component *com, gfc_constructor *con)
{
for (; con; con = con->next)
{
if (com == con->n.component)
return con;
}
return NULL;
}
void
gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
mpz_t offset;
ref = lvalue->ref;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_con = NULL;
mpz_init_set_si (offset, 0);
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
switch (ref->type)
{
case REF_ARRAY:
if (init == NULL)
{
expr->expr_type = EXPR_ARRAY;
if (ref->next)
{
assert (ref->next->type == REF_COMPONENT);
expr->ts.type = BT_DERIVED;
}
else
expr->ts = rvalue->ts;
expr->rank = ref->u.ar.as->rank;
}
else
assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
con = expr->value.constructor;
con = find_con_by_offset (offset, con);
if (con == NULL)
{
con = gfc_get_constructor();
mpz_set (con->n.offset, offset);
gfc_insert_constructor (expr, con);
}
break;
case REF_COMPONENT:
if (init == NULL)
{
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.derived = ref->u.c.sym;
}
else
assert (expr->expr_type == EXPR_STRUCTURE);
con = expr->value.constructor;
con = find_con_by_component (ref->u.c.component, con);
if (con == NULL)
{
con = gfc_get_constructor ();
con->n.component = ref->u.c.component;
con->next = expr->value.constructor;
expr->value.constructor = con;
}
break;
case REF_SUBSTRING:
gfc_todo_error ("Substring reference in DATA statement");
default:
abort ();
}
if (init == NULL)
{
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
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
{
assert (!last_con->expr);
last_con->expr = expr;
}
}
void
gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
mpz_t *offset_ret)
{
int i;
mpz_t delta;
mpz_t tmp;
bool forwards;
int cmp;
for (i = 0; i < ar->dimen; i++)
{
if (ar->dimen_type[i] != DIMEN_RANGE)
continue;
if (ar->stride[i])
{
mpz_add (section_index[i], section_index[i],
ar->stride[i]->value.integer);
if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
forwards = true;
else
forwards = false;
}
else
{
mpz_add_ui (section_index[i], section_index[i], 1);
forwards = true;
}
if (ar->end[i])
cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
if ((cmp > 0 && forwards)
|| (cmp < 0 && ! forwards))
{
if (ar->start[i])
mpz_set (section_index[i], ar->start[i]->value.integer);
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
}
else
break;
}
mpz_set_si (*offset_ret, 0);
mpz_init_set_si (delta, 1);
mpz_init (tmp);
for (i = 0; i < ar->dimen; i++)
{
mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset_ret, tmp, *offset_ret);
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
mpz_clear (tmp);
mpz_clear (delta);
}
static void
formalize_structure_cons (gfc_expr * expr)
{
gfc_constructor *head;
gfc_constructor *tail;
gfc_constructor *cur;
gfc_constructor *last;
gfc_constructor *c;
gfc_component *order;
c = expr->value.constructor;
if (c->n.component == NULL)
return;
head = tail = NULL;
for (order = expr->ts.derived->components; order; order = order->next)
{
last = NULL;
cur = c;
while (cur != NULL && cur->n.component != order)
{
last = cur;
cur = cur->next;
}
if (cur == NULL)
{
cur = gfc_get_constructor ();
}
else
{
if (last == NULL)
c = cur->next;
else
last->next = cur->next;
cur->next = NULL;
formalize_init_expr (cur->expr);
}
if (head == NULL)
head = tail = cur;
else
{
tail->next = cur;
tail = tail->next;
}
}
assert (c == NULL);
expr->value.constructor = head;
}
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:
c = expr->value.constructor;
while (c)
{
formalize_init_expr (c->expr);
c = c->next;
}
break;
case EXPR_STRUCTURE:
formalize_structure_cons (expr);
break;
default:
break;
}
}
void
gfc_formalize_init_value (gfc_symbol *sym)
{
formalize_init_expr (sym->value);
}
void
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
{
int i;
mpz_t delta;
mpz_t tmp;
mpz_set_si (*offset, 0);
mpz_init (tmp);
mpz_init_set_si (delta, 1);
for (i = 0; i < ar->dimen; i++)
{
mpz_init (section_index[i]);
switch (ar->dimen_type[i])
{
case DIMEN_ELEMENT:
case DIMEN_RANGE:
if (ar->start[i])
{
mpz_sub (tmp, ar->start[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_set (section_index[i], ar->start[i]->value.integer);
}
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
break;
case DIMEN_VECTOR:
gfc_todo_error ("Vectors sections in data statements");
default:
abort ();
}
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
mpz_clear (tmp);
mpz_clear (delta);
}