+2011-06-30 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/49540
+ * gfortran.h (gfc_constructor): Add repeat field.
+ * trans-array.c (gfc_conv_array_initializer): Handle repeat > 1.
+ * array.c (current_expand): Add repeat field.
+ (expand_constructor): Copy repeat.
+ * constructor.c (node_free, node_copy, gfc_constructor_get,
+ gfc_constructor_lookup): Handle repeat field.
+ (gfc_constructor_lookup_next, gfc_constructor_remove): New functions.
+ * data.h (gfc_assign_data_value): Add mpz_t * argument.
+ (gfc_assign_data_value_range): Removed.
+ * constructor.h (gfc_constructor_advance): Removed.
+ (gfc_constructor_lookup_next, gfc_constructor_remove): New prototypes.
+ * data.c (gfc_assign_data_value): Add REPEAT argument, handle it and
+ also handle overwriting a range with a single entry.
+ (gfc_assign_data_value_range): Removed.
+ * resolve.c (check_data_variable): Adjust gfc_assign_data_value
+ call. Use gfc_assign_data_value instead of
+ gfc_assign_data_value_expr.
+
2011-06-27 Janus Weil <janus@gcc.gnu.org>
PR fortran/49466
mpz_t *offset;
gfc_component *component;
+ mpz_t *repeat;
gfc_try (*expand_work_function) (gfc_expr *);
}
return FAILURE;
}
current_expand.offset = &c->offset;
+ current_expand.repeat = &c->repeat;
current_expand.component = c->n.component;
if (current_expand.expand_work_function (e) == FAILURE)
return FAILURE;
/* Array and structure constructors
- Copyright (C) 2009, 2010
+ Copyright (C) 2009, 2010, 2011
Free Software Foundation, Inc.
This file is part of GCC.
gfc_free_iterator (c->iterator, 1);
mpz_clear (c->offset);
+ mpz_clear (c->repeat);
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, 1);
return c;
}
gfc_constructor *
gfc_constructor_lookup (gfc_constructor_base base, int offset)
{
+ gfc_constructor *c;
splay_tree_node node;
if (!base)
node = splay_tree_lookup (base, (splay_tree_key) offset);
if (node)
- return (gfc_constructor*) node->value;
+ return (gfc_constructor *) node->value;
- return NULL;
+ /* Check if the previous node has a repeat count big enough to
+ cover the offset looked for. */
+ node = splay_tree_predecessor (base, (splay_tree_key) 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;
}
else
return NULL;
}
+
+
+void
+gfc_constructor_remove (gfc_constructor *ctor)
+{
+ if (ctor)
+ splay_tree_remove (ctor->base, mpz_get_si (ctor->offset));
+}
+
+
+gfc_constructor *
+gfc_constructor_lookup_next (gfc_constructor_base base, int offset)
+{
+ splay_tree_node node;
+
+ if (!base)
+ return NULL;
+
+ node = splay_tree_successor (base, (splay_tree_key) offset);
+ if (!node)
+ return NULL;
+
+ return (gfc_constructor *) node->value;
+}
/* Array and structure constructors
- Copyright (C) 2009, 2010
+ Copyright (C) 2009, 2010, 2011
Free Software Foundation, Inc.
This file is part of GCC.
Returns NULL if there is no next expression. */
gfc_constructor *gfc_constructor_next (gfc_constructor *ctor);
-gfc_constructor *gfc_constructor_advance (gfc_constructor *ctor, int n);
+/* Remove the gfc_constructor node from the splay tree. */
+void gfc_constructor_remove (gfc_constructor *);
+
+/* Return first constructor node after offset. */
+gfc_constructor *gfc_constructor_lookup_next (gfc_constructor_base, int);
#endif /* GFC_CONSTRUCTOR_H */
/* Supporting functions for resolving DATA statement.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
LVALUE already has an initialization, we extend this, otherwise we
- create a new one. */
+ create a new one. If REPEAT is non-NULL, initialize *REPEAT
+ consecutive values in LVALUE the same value in RVALUE. In that case,
+ LVALUE must refer to a full array, not an array section. */
gfc_try
-gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
+gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
+ mpz_t *repeat)
{
gfc_ref *ref;
gfc_expr *init;
&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) == SUCCESS)
+ {
+ 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,"Extension: "
+ "re-initialization of '%s' at %L",
+ symbol->name, &exprd->where) == FAILURE)
+ return FAILURE;
+ }
+
+ 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;
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:
}
mpz_clear (offset);
+ gcc_assert (repeat == NULL);
if (ref || last_ts->type == BT_CHARACTER)
{
}
-/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
- value in RVALUE. */
-
-gfc_try
-gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
- mpz_t index, mpz_t repeat)
-{
- 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;
- }
-
- mpz_clear (offset);
- mpz_clear (last_offset);
-
- return t;
-}
-
-
/* Modify the index of array section and re-calculate the array offset. */
void
/* Header for functions resolving DATA statements.
- Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2008, 2010, 2011 Free Software Foundation, Inc.
This file is part of GCC.
void gfc_formalize_init_value (gfc_symbol *);
void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
-gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
-gfc_try gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
+gfc_try gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t, mpz_t *);
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
gfc_component *component; /* Record the component being initialized. */
}
n;
+ mpz_t repeat; /* Record the repeat number of initial values in data
+ statement like "data a/5*10/". */
}
gfc_constructor;
mpz_set_ui (size, 0);
}
- t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
- offset, range);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, &range);
mpz_add (offset, offset, range);
mpz_clear (range);
mpz_sub_ui (values.left, values.left, 1);
mpz_sub_ui (size, size, 1);
- t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr,
+ offset, NULL);
if (t == FAILURE)
break;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
- tree index;
+ tree index, range;
VEC(constructor_elt,gc) *v = NULL;
switch (expr->expr_type)
else
index = NULL_TREE;
+ if (mpz_cmp_si (c->repeat, 1) > 0)
+ {
+ tree tmp1, tmp2;
+ mpz_t maxval;
+
+ mpz_init (maxval);
+ mpz_add (maxval, c->offset, c->repeat);
+ 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, gfc_array_index_type, tmp1, tmp2);
+ mpz_clear (maxval);
+ }
+ else
+ range = NULL;
+
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
case EXPR_STRUCTURE:
gfc_conv_structure (&se, c->expr, 1);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
-
default:
/* Catch those occasional beasts that do not simplify
for one reason or another, assuming that if they are
standard defying the frontend will catch them. */
gfc_conv_expr (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
}
+
+ 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);
+ }
}
break;
+2011-06-30 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/49540
+ * gfortran.dg/pr49540-1.f90: New test.
+ * gfortran.dg/pr49540-2.f90: New test.
+
2011-06-30 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
PR ada/49511
--- /dev/null
+! PR fortran/49540
+! { dg-do compile }
+block data
+ common /a/ b(100000,100)
+ data b /10000000 * 0.0/
+end block data
--- /dev/null
+! PR fortran/49540
+! { dg-do compile }
+! { dg-options "" }
+block data
+ common /a/ i(5,5)
+ data i /4, 23 * 5, 6/
+ data i(:,2) /1, 3 * 2, 3/
+ common /b/ j(5,5)
+ data j(2,:) /1, 3 * 2, 3/
+ data j /4, 23 * 5, 6/
+ common /c/ k(5,5)
+ data k(:,2) /1, 3 * 2, 3/
+ data k /4, 23 * 5, 6/
+ common /d/ l(5,5)
+ data l /4, 23 * 5, 6/
+ data l(2,:) /1, 3 * 2, 3/
+end block data
OSDN Git Service
