Skip to content

R
riscv-gcc-1
Commit e5880243 by Daniel Franke Committed by Daniel Franke
Options

re PR fortran/24978 (ICE in gfc_assign_data_value_range) 

gcc/fortran/:
2010-05-05  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/24978
	* gfortran.h: Removed repeat count from constructor, removed
	all usages.
	* data.h (gfc_assign_data_value_range): Changed return value from
	void to gfc_try.
	* data.c (gfc_assign_data_value): Add location to constructor element.
	(gfc_assign_data_value_range): Call gfc_assign_data_value()
	for each element in range. Return early if an error was generated.
	* resolve.c (check_data_variable): Stop early if range assignment
	generated an error.

gcc/testsuite/:
2010-05-05  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/24978
	* gfortran.dg/data_invalid.f90: New.

From-SVN: r159076
parent 5b042919
Showing with 176 additions and 205 deletions
gcc/fortran/ChangeLog
2010-05-05 Daniel Franke <franke.daniel@gmail.com>
PR fortran/24978
* gfortran.h: Removed repeat count from constructor, removed
all usages.
* data.h (gfc_assign_data_value_range): Changed return value from
void to gfc_try.
* data.c (gfc_assign_data_value): Add location to constructor element.
(gfc_assign_data_value_range): Call gfc_assign_data_value()
for each element in range. Return early if an error was generated.
* resolve.c (check_data_variable): Stop early if range assignment
generated an error.
2010-05-05 Janus Weil <janus@gcc.gnu.org>
PR fortran/43696
......
gcc/fortran/array.c
......@@ -1266,7 +1266,6 @@ typedef struct
mpz_t *offset;
gfc_component *component;
mpz_t *repeat;
gfc_try (*expand_work_function) (gfc_expr *);
}
......@@ -1501,7 +1500,6 @@ expand_constructor (gfc_constructor_base base)
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;
......
gcc/fortran/constructor.c
......@@ -36,7 +36,6 @@ node_free (splay_tree_value value)
gfc_free_iterator (c->iterator, 1);
mpz_clear (c->offset);
mpz_clear (c->repeat);
gfc_free (c);
}
......@@ -55,7 +54,6 @@ node_copy (splay_tree_node node, void *base)
c->n.component = src->n.component;
mpz_init_set (c->offset, src->offset);
mpz_init_set (c->repeat, src->repeat);
return c;
}
......@@ -80,7 +78,6 @@ gfc_constructor_get (void)
c->iterator = NULL;
mpz_init_set_si (c->offset, 0);
mpz_init_set_si (c->repeat, 0);
return c;
}
......@@ -172,7 +169,6 @@ gfc_constructor_insert_expr (gfc_constructor_base *base,
gfc_constructor *
gfc_constructor_lookup (gfc_constructor_base base, int offset)
{
gfc_constructor *c;
splay_tree_node node;
if (!base)
......@@ -182,22 +178,7 @@ gfc_constructor_lookup (gfc_constructor_base base, int offset)
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;
}
......
gcc/fortran/data.c
......@@ -288,7 +288,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
if (!con)
{
con = gfc_constructor_insert_expr (&expr->value.constructor,
NULL, NULL,
NULL, &rvalue->where,
mpz_get_si (offset));
}
break;
......@@ -352,8 +352,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
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);
......@@ -371,149 +373,35 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
/* 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
......
gcc/fortran/data.h
......@@ -20,5 +20,5 @@ along with GCC; see the file COPYING3. If not see
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);
void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
gfc_try gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
gcc/fortran/gfortran.h
......@@ -2187,8 +2187,6 @@ typedef struct gfc_constructor
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;
......
gcc/fortran/resolve.c
......@@ -11781,11 +11781,14 @@ check_data_variable (gfc_data_variable *var, locus *where)
mpz_set_ui (size, 0);
}
gfc_assign_data_value_range (var->expr, values.vnode->expr,
offset, range);
t = gfc_assign_data_value_range (var->expr, values.vnode->expr,
offset, range);
mpz_add (offset, offset, range);
mpz_clear (range);
if (t == FAILURE)
break;
}
/* Assign initial value to symbol. */
......
gcc/fortran/trans-array.c
......@@ -4133,11 +4133,10 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
{
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)
......@@ -4190,42 +4189,13 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
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:
......@@ -4239,14 +4209,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
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;
}
}
......
gcc/testsuite/ChangeLog
2010-05-05 Daniel Franke <franke.daniel@gmail.com>
PR fortran/24978
* gfortran.dg/data_invalid.f90: New.
2010-05-05 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/lto2.adb: New test.
......
gcc/testsuite/gfortran.dg/data_invalid.f90 0 → 100644
! { dg-do "compile" }
! { dg-options "-std=f95 -fmax-errors=0" }
!
! Testcases from PR fortran/24978
!
SUBROUTINE data_init_scalar_invalid()
integer :: a
data a / 1 /
data a / 1 / ! { dg-error "re-initialization" }
integer :: b = 0
data b / 1 / ! { dg-error "re-initialization" }
END SUBROUTINE
SUBROUTINE data_init_array_invalid()
! initialize (at least) one element, re-initialize full array
integer :: a(3)
data a(2) / 2 /
data a / 3*1 / ! { dg-error "re-initialization" }
! initialize (at least) one element, re-initialize subsection including the element
integer :: b(3)
data b(2) / 2 /
data b(1:2) / 2*1 / ! { dg-error "re-initialization" }
! initialize subsection, re-initialize (intersecting) subsection
integer :: c(3)
data c(1:2) / 2*1 /
data c(2:3) / 1,1 / ! { dg-error "re-initialization" }
! initialize subsection, re-initialize full array
integer :: d(3)
data d(2:3) / 2*1 /
data d / 2*2, 3 / ! { dg-error "re-initialization" }
! full array initializer, re-initialize (at least) one element
integer :: e(3)
data e / 3*1 /
data e(2) / 2 / ! { dg-error "re-initialization" }
integer :: f(3) = 0 ! { dg-error "already is initialized" }
data f(2) / 1 /
! full array initializer, re-initialize subsection
integer :: g(3)
data g / 3*1 /
data g(1:2) / 2*2 / ! { dg-error "re-initialization" }
integer :: h(3) = 1 ! { dg-error "already is initialized" }
data h(2:3) / 2*2 /
! full array initializer, re-initialize full array
integer :: i(3)
data i / 3*1 /
data i / 2,2,2 / ! { dg-error "re-initialization" }
integer :: j(3) = 1 ! { dg-error "already is initialized" }
data j / 3*2 /
END SUBROUTINE
SUBROUTINE data_init_matrix_invalid()
! initialize (at least) one element, re-initialize full matrix
integer :: a(3,3)
data a(2,2) / 1 /
data a / 9*2 / ! { dg-error "re-initialization" }
! initialize (at least) one element, re-initialize subsection
integer :: b(3,3)
data b(2,2) / 1 /
data b(2,:) / 3*2 / ! { dg-error "re-initialization" }
! initialize subsection, re-initialize (intersecting) subsection
integer :: c(3,3)
data c(3,:) / 3*1 /, c(:,3) / 3*2 / ! { dg-error "re-initialization" }
! initialize subsection, re-initialize full array
integer :: d(3,3)
data d(2,:) / 1,2,3 /
data d / 9*4 / ! { dg-error "re-initialization" }
! full array initializer, re-initialize (at least) one element
integer :: e(3,3)
data e / 9*1 /
data e(2,3) / 2 / ! { dg-error "re-initialization" }
integer :: f(3,3) = 1 ! { dg-error "already is initialized" }
data f(3,2) / 2 /
! full array initializer, re-initialize subsection
integer :: g(3,3)
data g / 9 * 1 /
data g(2:3,2:3) / 2, 2*3, 4 / ! { dg-error "re-initialization" }
integer :: h(3,3) = 1 ! { dg-error "already is initialized" }
data h(2:3,2:3) / 2, 2*3, 4 /
! full array initializer, re-initialize full array
integer :: i(3,3)
data i / 3*1, 3*2, 3*3 /
data i / 9 * 1 / ! { dg-error "re-initialization" }
integer :: j(3,3) = 0 ! { dg-error "already is initialized" }
data j / 9 * 1 /
END SUBROUTINE
SUBROUTINE data_init_misc_invalid()
! wrong number of dimensions
integer :: a(3)
data a(1,1) / 1 / ! { dg-error "Rank mismatch" }
! index out-of-bounds, direct access
integer :: b(3)
data b(-2) / 1 / ! { dg-error "below array lower bound" }
! index out-of-bounds, implied do-loop (PR32315)
integer :: i
character(len=20), dimension(4) :: string
data (string(i), i = 1, 5) / 'A', 'B', 'C', 'D', 'E' / ! { dg-error "above array upper bound" }
END SUBROUTINE
! { dg-excess-errors "" }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment