gfc_free_iterator (c->iterator, 1);
mpz_clear (c->offset);
- mpz_clear (c->repeat);
gfc_free (c);
}
c->n.component = src->n.component;
mpz_init_set (c->offset, src->offset);
- mpz_init_set (c->repeat, src->repeat);
return c;
}
c->iterator = NULL;
mpz_init_set_si (c->offset, 0);
- mpz_init_set_si (c->repeat, 0);
return c;
}
gfc_constructor *
gfc_constructor_lookup (gfc_constructor_base base, int offset)
{
- gfc_constructor *c;
splay_tree_node node;
if (!base)
if (node)
return (gfc_constructor*) node->value;
- /* Check if the previous node has a repeat count big enough to
- cover the offset looked for. */
- node = splay_tree_predecessor (base, offset);
- if (!node)
- return NULL;
-
- c = (gfc_constructor*) node->value;
- if (mpz_cmp_si (c->repeat, 1) > 0)
- {
- if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset)
- c = NULL;
- }
- else
- c = NULL;
-
- return c;
+ return NULL;
}
if (!con)
{
con = gfc_constructor_insert_expr (&expr->value.constructor,
- NULL, NULL,
+ NULL, &rvalue->where,
mpz_get_si (offset));
}
break;
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
- gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
- "of '%s' at %L", symbol->name, &expr->where);
+ if (gfc_notify_std (GFC_STD_GNU,"Extension: "
+ "re-initialization of '%s' at %L",
+ symbol->name, &expr->where) == FAILURE)
+ return FAILURE;
}
expr = gfc_copy_expr (rvalue);
/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
- value in RVALUE. For the nonce, LVALUE must refer to a full array, not
- an array section. */
+ value in RVALUE. */
-void
+gfc_try
gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
mpz_t index, mpz_t repeat)
{
- gfc_ref *ref;
- gfc_expr *init, *expr;
- gfc_constructor *con, *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)
- {
- /* 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 (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;
- }
- else
- gcc_assert (expr->expr_type == EXPR_ARRAY);
-
- if (ref->u.ar.type == AR_ELEMENT)
- {
- get_array_index (&ref->u.ar, &offset);
-
- /* This had better not be the bottom of the reference.
- We can still get to a full array via a component. */
- gcc_assert (ref->next != NULL);
- }
- else
- {
- mpz_set (offset, index);
-
- /* We're at a full array or an array section. This means
- that we've better have found a full array, and that we're
- at the bottom of the reference. */
- gcc_assert (ref->u.ar.type == AR_FULL);
- gcc_assert (ref->next == NULL);
- }
-
- con = gfc_constructor_lookup (expr->value.constructor,
- mpz_get_si (offset));
- if (con == NULL)
- {
- con = gfc_constructor_insert_expr (&expr->value.constructor,
- NULL, NULL,
- mpz_get_si (offset));
- if (ref->next == NULL)
- mpz_set (con->repeat, repeat);
- }
- else
- gcc_assert (ref->next != NULL);
- 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;
- }
-
- /* Since we're only intending to initialize arrays here,
- there better be an inner reference. */
- gcc_assert (ref->next != NULL);
- break;
-
- case REF_SUBSTRING:
- 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_t offset, last_offset;
+ gfc_try t;
+
+ mpz_init (offset);
+ mpz_init (last_offset);
+ mpz_add (last_offset, index, repeat);
+
+ t = SUCCESS;
+ for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0;
+ mpz_add_ui (offset, offset, 1))
+ if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE)
+ {
+ t = FAILURE;
+ break;
+ }
- if (last_ts->type == BT_CHARACTER)
- expr = create_character_intializer (init, last_ts, NULL, rvalue);
- else
- {
- /* We should never be overwriting an existing initializer. */
- gcc_assert (!init);
+ mpz_clear (offset);
+ mpz_clear (last_offset);
- 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 t;
}
+
/* Modify the index of array section and re-calculate the array offset. */
void
{
gfc_constructor *c;
tree tmp;
- mpz_t maxval;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
- tree index, range;
+ tree index;
VEC(constructor_elt,gc) *v = NULL;
switch (expr->expr_type)
index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
- mpz_init (maxval);
- if (mpz_cmp_si (c->repeat, 0) != 0)
- {
- tree tmp1, tmp2;
-
- mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->offset, maxval);
- mpz_sub_ui (maxval, maxval, 1);
- tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- if (mpz_cmp_si (c->offset, 0) != 0)
- {
- mpz_add_ui (maxval, c->offset, 1);
- tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- }
- else
- tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
-
- range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
- }
- else
- range = NULL;
- mpz_clear (maxval);
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
- if (range == NULL_TREE)
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
- else
- {
- if (index != NULL_TREE)
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
- CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
- }
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
case EXPR_STRUCTURE:
for one reason or another, assuming that if they are
standard defying the frontend will catch them. */
gfc_conv_expr (&se, c->expr);
- if (range == NULL_TREE)
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
- else
- {
- if (index != NULL_TREE)
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
- CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
- }
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
}
}
OSDN Git Service
