/* Supporting functions for resolving DATA statement.
|
/* Supporting functions for resolving DATA statement.
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Lifang Zeng <zlf605@hotmail.com>
|
Contributed by Lifang Zeng <zlf605@hotmail.com>
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
GCC is free software; you can redistribute it and/or modify it under
|
the terms of the GNU General Public License as published by the Free
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
/* Notes for DATA statement implementation:
|
/* Notes for DATA statement implementation:
|
|
|
We first assign initial value to each symbol by gfc_assign_data_value
|
We first assign initial value to each symbol by gfc_assign_data_value
|
during resolving DATA statement. Refer to check_data_variable and
|
during resolving DATA statement. Refer to check_data_variable and
|
traverse_data_list in resolve.c.
|
traverse_data_list in resolve.c.
|
|
|
The complexity exists in the handling of array section, implied do
|
The complexity exists in the handling of array section, implied do
|
and array of struct appeared in DATA statement.
|
and array of struct appeared in DATA statement.
|
|
|
We call gfc_conv_structure, gfc_con_array_array_initializer,
|
We call gfc_conv_structure, gfc_con_array_array_initializer,
|
etc., to convert the initial value. Refer to trans-expr.c and
|
etc., to convert the initial value. Refer to trans-expr.c and
|
trans-array.c. */
|
trans-array.c. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "data.h"
|
#include "data.h"
|
#include "constructor.h"
|
#include "constructor.h"
|
|
|
static void formalize_init_expr (gfc_expr *);
|
static void formalize_init_expr (gfc_expr *);
|
|
|
/* Calculate the array element offset. */
|
/* Calculate the array element offset. */
|
|
|
static void
|
static void
|
get_array_index (gfc_array_ref *ar, mpz_t *offset)
|
get_array_index (gfc_array_ref *ar, mpz_t *offset)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
int i;
|
int i;
|
mpz_t delta;
|
mpz_t delta;
|
mpz_t tmp;
|
mpz_t tmp;
|
|
|
mpz_init (tmp);
|
mpz_init (tmp);
|
mpz_set_si (*offset, 0);
|
mpz_set_si (*offset, 0);
|
mpz_init_set_si (delta, 1);
|
mpz_init_set_si (delta, 1);
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
e = gfc_copy_expr (ar->start[i]);
|
e = gfc_copy_expr (ar->start[i]);
|
gfc_simplify_expr (e, 1);
|
gfc_simplify_expr (e, 1);
|
|
|
if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
|
if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
|
|| (gfc_is_constant_expr (ar->as->upper[i]) == 0)
|
|| (gfc_is_constant_expr (ar->as->upper[i]) == 0)
|
|| (gfc_is_constant_expr (e) == 0))
|
|| (gfc_is_constant_expr (e) == 0))
|
gfc_error ("non-constant array in DATA statement %L", &ar->where);
|
gfc_error ("non-constant array in DATA statement %L", &ar->where);
|
|
|
mpz_set (tmp, e->value.integer);
|
mpz_set (tmp, e->value.integer);
|
mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
|
mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
|
mpz_mul (tmp, tmp, delta);
|
mpz_mul (tmp, tmp, delta);
|
mpz_add (*offset, tmp, *offset);
|
mpz_add (*offset, tmp, *offset);
|
|
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
ar->as->lower[i]->value.integer);
|
ar->as->lower[i]->value.integer);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_mul (delta, tmp, delta);
|
mpz_mul (delta, tmp, delta);
|
}
|
}
|
mpz_clear (delta);
|
mpz_clear (delta);
|
mpz_clear (tmp);
|
mpz_clear (tmp);
|
}
|
}
|
|
|
/* Find if there is a constructor which component is equal to COM.
|
/* Find if there is a constructor which component is equal to COM.
|
TODO: remove this, use symbol.c(gfc_find_component) instead. */
|
TODO: remove this, use symbol.c(gfc_find_component) instead. */
|
|
|
static gfc_constructor *
|
static gfc_constructor *
|
find_con_by_component (gfc_component *com, gfc_constructor_base base)
|
find_con_by_component (gfc_component *com, gfc_constructor_base base)
|
{
|
{
|
gfc_constructor *c;
|
gfc_constructor *c;
|
|
|
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
|
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
|
if (com == c->n.component)
|
if (com == c->n.component)
|
return c;
|
return c;
|
|
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
|
|
/* Create a character type initialization expression from RVALUE.
|
/* Create a character type initialization expression from RVALUE.
|
TS [and REF] describe [the substring of] the variable being initialized.
|
TS [and REF] describe [the substring of] the variable being initialized.
|
INIT is the existing initializer, not NULL. Initialization is performed
|
INIT is the existing initializer, not NULL. Initialization is performed
|
according to normal assignment rules. */
|
according to normal assignment rules. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
|
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
|
gfc_ref *ref, gfc_expr *rvalue)
|
gfc_ref *ref, gfc_expr *rvalue)
|
{
|
{
|
int len, start, end;
|
int len, start, end;
|
gfc_char_t *dest;
|
gfc_char_t *dest;
|
|
|
gfc_extract_int (ts->u.cl->length, &len);
|
gfc_extract_int (ts->u.cl->length, &len);
|
|
|
if (init == NULL)
|
if (init == NULL)
|
{
|
{
|
/* Create a new initializer. */
|
/* Create a new initializer. */
|
init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
|
init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
|
init->ts = *ts;
|
init->ts = *ts;
|
}
|
}
|
|
|
dest = init->value.character.string;
|
dest = init->value.character.string;
|
|
|
if (ref)
|
if (ref)
|
{
|
{
|
gfc_expr *start_expr, *end_expr;
|
gfc_expr *start_expr, *end_expr;
|
|
|
gcc_assert (ref->type == REF_SUBSTRING);
|
gcc_assert (ref->type == REF_SUBSTRING);
|
|
|
/* Only set a substring of the destination. Fortran substring bounds
|
/* Only set a substring of the destination. Fortran substring bounds
|
are one-based [start, end], we want zero based [start, end). */
|
are one-based [start, end], we want zero based [start, end). */
|
start_expr = gfc_copy_expr (ref->u.ss.start);
|
start_expr = gfc_copy_expr (ref->u.ss.start);
|
end_expr = gfc_copy_expr (ref->u.ss.end);
|
end_expr = gfc_copy_expr (ref->u.ss.end);
|
|
|
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
|
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
|
{
|
{
|
gfc_error ("failure to simplify substring reference in DATA "
|
gfc_error ("failure to simplify substring reference in DATA "
|
"statement at %L", &ref->u.ss.start->where);
|
"statement at %L", &ref->u.ss.start->where);
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
gfc_extract_int (start_expr, &start);
|
gfc_extract_int (start_expr, &start);
|
start--;
|
start--;
|
gfc_extract_int (end_expr, &end);
|
gfc_extract_int (end_expr, &end);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Set the whole string. */
|
/* Set the whole string. */
|
start = 0;
|
start = 0;
|
end = len;
|
end = len;
|
}
|
}
|
|
|
/* Copy the initial value. */
|
/* Copy the initial value. */
|
if (rvalue->ts.type == BT_HOLLERITH)
|
if (rvalue->ts.type == BT_HOLLERITH)
|
len = rvalue->representation.length - rvalue->ts.u.pad;
|
len = rvalue->representation.length - rvalue->ts.u.pad;
|
else
|
else
|
len = rvalue->value.character.length;
|
len = rvalue->value.character.length;
|
|
|
if (len > end - start)
|
if (len > end - start)
|
{
|
{
|
gfc_warning_now ("Initialization string starting at %L was "
|
gfc_warning_now ("Initialization string starting at %L was "
|
"truncated to fit the variable (%d/%d)",
|
"truncated to fit the variable (%d/%d)",
|
&rvalue->where, end - start, len);
|
&rvalue->where, end - start, len);
|
len = end - start;
|
len = end - start;
|
}
|
}
|
|
|
if (rvalue->ts.type == BT_HOLLERITH)
|
if (rvalue->ts.type == BT_HOLLERITH)
|
{
|
{
|
int i;
|
int i;
|
for (i = 0; i < len; i++)
|
for (i = 0; i < len; i++)
|
dest[start+i] = rvalue->representation.string[i];
|
dest[start+i] = rvalue->representation.string[i];
|
}
|
}
|
else
|
else
|
memcpy (&dest[start], rvalue->value.character.string,
|
memcpy (&dest[start], rvalue->value.character.string,
|
len * sizeof (gfc_char_t));
|
len * sizeof (gfc_char_t));
|
|
|
/* Pad with spaces. Substrings will already be blanked. */
|
/* Pad with spaces. Substrings will already be blanked. */
|
if (len < end - start && ref == NULL)
|
if (len < end - start && ref == NULL)
|
gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
|
gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
|
|
|
if (rvalue->ts.type == BT_HOLLERITH)
|
if (rvalue->ts.type == BT_HOLLERITH)
|
{
|
{
|
init->representation.length = init->value.character.length;
|
init->representation.length = init->value.character.length;
|
init->representation.string
|
init->representation.string
|
= gfc_widechar_to_char (init->value.character.string,
|
= gfc_widechar_to_char (init->value.character.string,
|
init->value.character.length);
|
init->value.character.length);
|
}
|
}
|
|
|
return init;
|
return init;
|
}
|
}
|
|
|
|
|
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
|
/* Assign the initial value RVALUE to LVALUE's symbol->value. If the
|
LVALUE already has an initialization, we extend this, otherwise we
|
LVALUE already has an initialization, we extend this, otherwise we
|
create a new one. If REPEAT is non-NULL, initialize *REPEAT
|
create a new one. If REPEAT is non-NULL, initialize *REPEAT
|
consecutive values in LVALUE the same value in RVALUE. In that case,
|
consecutive values in LVALUE the same value in RVALUE. In that case,
|
LVALUE must refer to a full array, not an array section. */
|
LVALUE must refer to a full array, not an array section. */
|
|
|
gfc_try
|
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)
|
mpz_t *repeat)
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_expr *init;
|
gfc_expr *init;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
gfc_constructor *con;
|
gfc_constructor *con;
|
gfc_constructor *last_con;
|
gfc_constructor *last_con;
|
gfc_symbol *symbol;
|
gfc_symbol *symbol;
|
gfc_typespec *last_ts;
|
gfc_typespec *last_ts;
|
mpz_t offset;
|
mpz_t offset;
|
|
|
symbol = lvalue->symtree->n.sym;
|
symbol = lvalue->symtree->n.sym;
|
init = symbol->value;
|
init = symbol->value;
|
last_ts = &symbol->ts;
|
last_ts = &symbol->ts;
|
last_con = NULL;
|
last_con = NULL;
|
mpz_init_set_si (offset, 0);
|
mpz_init_set_si (offset, 0);
|
|
|
/* Find/create the parent expressions for subobject references. */
|
/* Find/create the parent expressions for subobject references. */
|
for (ref = lvalue->ref; ref; ref = ref->next)
|
for (ref = lvalue->ref; ref; ref = ref->next)
|
{
|
{
|
/* Break out of the loop if we find a substring. */
|
/* Break out of the loop if we find a substring. */
|
if (ref->type == REF_SUBSTRING)
|
if (ref->type == REF_SUBSTRING)
|
{
|
{
|
/* A substring should always be the last subobject reference. */
|
/* A substring should always be the last subobject reference. */
|
gcc_assert (ref->next == NULL);
|
gcc_assert (ref->next == NULL);
|
break;
|
break;
|
}
|
}
|
|
|
/* Use the existing initializer expression if it exists. Otherwise
|
/* Use the existing initializer expression if it exists. Otherwise
|
create a new one. */
|
create a new one. */
|
if (init == NULL)
|
if (init == NULL)
|
expr = gfc_get_expr ();
|
expr = gfc_get_expr ();
|
else
|
else
|
expr = init;
|
expr = init;
|
|
|
/* Find or create this element. */
|
/* Find or create this element. */
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
if (ref->u.ar.as->rank == 0)
|
if (ref->u.ar.as->rank == 0)
|
{
|
{
|
gcc_assert (ref->u.ar.as->corank > 0);
|
gcc_assert (ref->u.ar.as->corank > 0);
|
if (init == NULL)
|
if (init == NULL)
|
free (expr);
|
free (expr);
|
continue;
|
continue;
|
}
|
}
|
|
|
if (init && expr->expr_type != EXPR_ARRAY)
|
if (init && expr->expr_type != EXPR_ARRAY)
|
{
|
{
|
gfc_error ("'%s' at %L already is initialized at %L",
|
gfc_error ("'%s' at %L already is initialized at %L",
|
lvalue->symtree->n.sym->name, &lvalue->where,
|
lvalue->symtree->n.sym->name, &lvalue->where,
|
&init->where);
|
&init->where);
|
goto abort;
|
goto abort;
|
}
|
}
|
|
|
if (init == NULL)
|
if (init == NULL)
|
{
|
{
|
/* The element typespec will be the same as the array
|
/* The element typespec will be the same as the array
|
typespec. */
|
typespec. */
|
expr->ts = *last_ts;
|
expr->ts = *last_ts;
|
/* Setup the expression to hold the constructor. */
|
/* Setup the expression to hold the constructor. */
|
expr->expr_type = EXPR_ARRAY;
|
expr->expr_type = EXPR_ARRAY;
|
expr->rank = ref->u.ar.as->rank;
|
expr->rank = ref->u.ar.as->rank;
|
}
|
}
|
|
|
if (ref->u.ar.type == AR_ELEMENT)
|
if (ref->u.ar.type == AR_ELEMENT)
|
get_array_index (&ref->u.ar, &offset);
|
get_array_index (&ref->u.ar, &offset);
|
else
|
else
|
mpz_set (offset, index);
|
mpz_set (offset, index);
|
|
|
/* Check the bounds. */
|
/* Check the bounds. */
|
if (mpz_cmp_si (offset, 0) < 0)
|
if (mpz_cmp_si (offset, 0) < 0)
|
{
|
{
|
gfc_error ("Data element below array lower bound at %L",
|
gfc_error ("Data element below array lower bound at %L",
|
&lvalue->where);
|
&lvalue->where);
|
goto abort;
|
goto abort;
|
}
|
}
|
else if (repeat != NULL
|
else if (repeat != NULL
|
&& ref->u.ar.type != AR_ELEMENT)
|
&& ref->u.ar.type != AR_ELEMENT)
|
{
|
{
|
mpz_t size, end;
|
mpz_t size, end;
|
gcc_assert (ref->u.ar.type == AR_FULL
|
gcc_assert (ref->u.ar.type == AR_FULL
|
&& ref->next == NULL);
|
&& ref->next == NULL);
|
mpz_init_set (end, offset);
|
mpz_init_set (end, offset);
|
mpz_add (end, end, *repeat);
|
mpz_add (end, end, *repeat);
|
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
|
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
|
{
|
{
|
if (mpz_cmp (end, size) > 0)
|
if (mpz_cmp (end, size) > 0)
|
{
|
{
|
mpz_clear (size);
|
mpz_clear (size);
|
gfc_error ("Data element above array upper bound at %L",
|
gfc_error ("Data element above array upper bound at %L",
|
&lvalue->where);
|
&lvalue->where);
|
goto abort;
|
goto abort;
|
}
|
}
|
mpz_clear (size);
|
mpz_clear (size);
|
}
|
}
|
|
|
con = gfc_constructor_lookup (expr->value.constructor,
|
con = gfc_constructor_lookup (expr->value.constructor,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
if (!con)
|
if (!con)
|
{
|
{
|
con = gfc_constructor_lookup_next (expr->value.constructor,
|
con = gfc_constructor_lookup_next (expr->value.constructor,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
if (con != NULL && mpz_cmp (con->offset, end) >= 0)
|
if (con != NULL && mpz_cmp (con->offset, end) >= 0)
|
con = NULL;
|
con = NULL;
|
}
|
}
|
|
|
/* Overwriting an existing initializer is non-standard but
|
/* Overwriting an existing initializer is non-standard but
|
usually only provokes a warning from other compilers. */
|
usually only provokes a warning from other compilers. */
|
if (con != NULL && con->expr != NULL)
|
if (con != NULL && con->expr != NULL)
|
{
|
{
|
/* Order in which the expressions arrive here depends on
|
/* Order in which the expressions arrive here depends on
|
whether they are from data statements or F95 style
|
whether they are from data statements or F95 style
|
declarations. Therefore, check which is the most
|
declarations. Therefore, check which is the most
|
recent. */
|
recent. */
|
gfc_expr *exprd;
|
gfc_expr *exprd;
|
exprd = (LOCATION_LINE (con->expr->where.lb->location)
|
exprd = (LOCATION_LINE (con->expr->where.lb->location)
|
> LOCATION_LINE (rvalue->where.lb->location))
|
> LOCATION_LINE (rvalue->where.lb->location))
|
? con->expr : rvalue;
|
? con->expr : rvalue;
|
if (gfc_notify_std (GFC_STD_GNU,"Extension: "
|
if (gfc_notify_std (GFC_STD_GNU,"Extension: "
|
"re-initialization of '%s' at %L",
|
"re-initialization of '%s' at %L",
|
symbol->name, &exprd->where) == FAILURE)
|
symbol->name, &exprd->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
while (con != NULL)
|
while (con != NULL)
|
{
|
{
|
gfc_constructor *next_con = gfc_constructor_next (con);
|
gfc_constructor *next_con = gfc_constructor_next (con);
|
|
|
if (mpz_cmp (con->offset, end) >= 0)
|
if (mpz_cmp (con->offset, end) >= 0)
|
break;
|
break;
|
if (mpz_cmp (con->offset, offset) < 0)
|
if (mpz_cmp (con->offset, offset) < 0)
|
{
|
{
|
gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
|
gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
|
mpz_sub (con->repeat, offset, con->offset);
|
mpz_sub (con->repeat, offset, con->offset);
|
}
|
}
|
else if (mpz_cmp_si (con->repeat, 1) > 0
|
else if (mpz_cmp_si (con->repeat, 1) > 0
|
&& mpz_get_si (con->offset)
|
&& mpz_get_si (con->offset)
|
+ mpz_get_si (con->repeat) > mpz_get_si (end))
|
+ mpz_get_si (con->repeat) > mpz_get_si (end))
|
{
|
{
|
int endi;
|
int endi;
|
splay_tree_node node
|
splay_tree_node node
|
= splay_tree_lookup (con->base,
|
= splay_tree_lookup (con->base,
|
mpz_get_si (con->offset));
|
mpz_get_si (con->offset));
|
gcc_assert (node
|
gcc_assert (node
|
&& con == (gfc_constructor *) node->value
|
&& con == (gfc_constructor *) node->value
|
&& node->key == (splay_tree_key)
|
&& node->key == (splay_tree_key)
|
mpz_get_si (con->offset));
|
mpz_get_si (con->offset));
|
endi = mpz_get_si (con->offset)
|
endi = mpz_get_si (con->offset)
|
+ mpz_get_si (con->repeat);
|
+ mpz_get_si (con->repeat);
|
if (endi > mpz_get_si (end) + 1)
|
if (endi > mpz_get_si (end) + 1)
|
mpz_set_si (con->repeat, endi - mpz_get_si (end));
|
mpz_set_si (con->repeat, endi - mpz_get_si (end));
|
else
|
else
|
mpz_set_si (con->repeat, 1);
|
mpz_set_si (con->repeat, 1);
|
mpz_set (con->offset, end);
|
mpz_set (con->offset, end);
|
node->key = (splay_tree_key) mpz_get_si (end);
|
node->key = (splay_tree_key) mpz_get_si (end);
|
break;
|
break;
|
}
|
}
|
else
|
else
|
gfc_constructor_remove (con);
|
gfc_constructor_remove (con);
|
con = next_con;
|
con = next_con;
|
}
|
}
|
|
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
NULL, &rvalue->where,
|
NULL, &rvalue->where,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
mpz_set (con->repeat, *repeat);
|
mpz_set (con->repeat, *repeat);
|
repeat = NULL;
|
repeat = NULL;
|
mpz_clear (end);
|
mpz_clear (end);
|
break;
|
break;
|
}
|
}
|
else
|
else
|
{
|
{
|
mpz_t size;
|
mpz_t size;
|
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
|
if (spec_size (ref->u.ar.as, &size) == SUCCESS)
|
{
|
{
|
if (mpz_cmp (offset, size) >= 0)
|
if (mpz_cmp (offset, size) >= 0)
|
{
|
{
|
mpz_clear (size);
|
mpz_clear (size);
|
gfc_error ("Data element above array upper bound at %L",
|
gfc_error ("Data element above array upper bound at %L",
|
&lvalue->where);
|
&lvalue->where);
|
goto abort;
|
goto abort;
|
}
|
}
|
mpz_clear (size);
|
mpz_clear (size);
|
}
|
}
|
}
|
}
|
|
|
con = gfc_constructor_lookup (expr->value.constructor,
|
con = gfc_constructor_lookup (expr->value.constructor,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
if (!con)
|
if (!con)
|
{
|
{
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
NULL, &rvalue->where,
|
NULL, &rvalue->where,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
}
|
}
|
else if (mpz_cmp_si (con->repeat, 1) > 0)
|
else if (mpz_cmp_si (con->repeat, 1) > 0)
|
{
|
{
|
/* Need to split a range. */
|
/* Need to split a range. */
|
if (mpz_cmp (con->offset, offset) < 0)
|
if (mpz_cmp (con->offset, offset) < 0)
|
{
|
{
|
gfc_constructor *pred_con = con;
|
gfc_constructor *pred_con = con;
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
con = gfc_constructor_insert_expr (&expr->value.constructor,
|
NULL, &con->where,
|
NULL, &con->where,
|
mpz_get_si (offset));
|
mpz_get_si (offset));
|
con->expr = gfc_copy_expr (pred_con->expr);
|
con->expr = gfc_copy_expr (pred_con->expr);
|
mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
|
mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
|
mpz_sub (con->repeat, con->repeat, offset);
|
mpz_sub (con->repeat, con->repeat, offset);
|
mpz_sub (pred_con->repeat, offset, pred_con->offset);
|
mpz_sub (pred_con->repeat, offset, pred_con->offset);
|
}
|
}
|
if (mpz_cmp_si (con->repeat, 1) > 0)
|
if (mpz_cmp_si (con->repeat, 1) > 0)
|
{
|
{
|
gfc_constructor *succ_con;
|
gfc_constructor *succ_con;
|
succ_con
|
succ_con
|
= gfc_constructor_insert_expr (&expr->value.constructor,
|
= gfc_constructor_insert_expr (&expr->value.constructor,
|
NULL, &con->where,
|
NULL, &con->where,
|
mpz_get_si (offset) + 1);
|
mpz_get_si (offset) + 1);
|
succ_con->expr = gfc_copy_expr (con->expr);
|
succ_con->expr = gfc_copy_expr (con->expr);
|
mpz_sub_ui (succ_con->repeat, con->repeat, 1);
|
mpz_sub_ui (succ_con->repeat, con->repeat, 1);
|
mpz_set_si (con->repeat, 1);
|
mpz_set_si (con->repeat, 1);
|
}
|
}
|
}
|
}
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
if (init == NULL)
|
if (init == NULL)
|
{
|
{
|
/* Setup the expression to hold the constructor. */
|
/* Setup the expression to hold the constructor. */
|
expr->expr_type = EXPR_STRUCTURE;
|
expr->expr_type = EXPR_STRUCTURE;
|
expr->ts.type = BT_DERIVED;
|
expr->ts.type = BT_DERIVED;
|
expr->ts.u.derived = ref->u.c.sym;
|
expr->ts.u.derived = ref->u.c.sym;
|
}
|
}
|
else
|
else
|
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
|
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
|
last_ts = &ref->u.c.component->ts;
|
last_ts = &ref->u.c.component->ts;
|
|
|
/* Find the same element in the existing constructor. */
|
/* Find the same element in the existing constructor. */
|
con = find_con_by_component (ref->u.c.component,
|
con = find_con_by_component (ref->u.c.component,
|
expr->value.constructor);
|
expr->value.constructor);
|
|
|
if (con == NULL)
|
if (con == NULL)
|
{
|
{
|
/* Create a new constructor. */
|
/* Create a new constructor. */
|
con = gfc_constructor_append_expr (&expr->value.constructor,
|
con = gfc_constructor_append_expr (&expr->value.constructor,
|
NULL, NULL);
|
NULL, NULL);
|
con->n.component = ref->u.c.component;
|
con->n.component = ref->u.c.component;
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
if (init == NULL)
|
if (init == NULL)
|
{
|
{
|
/* Point the container at the new expression. */
|
/* Point the container at the new expression. */
|
if (last_con == NULL)
|
if (last_con == NULL)
|
symbol->value = expr;
|
symbol->value = expr;
|
else
|
else
|
last_con->expr = expr;
|
last_con->expr = expr;
|
}
|
}
|
init = con->expr;
|
init = con->expr;
|
last_con = con;
|
last_con = con;
|
}
|
}
|
|
|
mpz_clear (offset);
|
mpz_clear (offset);
|
gcc_assert (repeat == NULL);
|
gcc_assert (repeat == NULL);
|
|
|
if (ref || last_ts->type == BT_CHARACTER)
|
if (ref || last_ts->type == BT_CHARACTER)
|
{
|
{
|
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
|
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
|
return FAILURE;
|
return FAILURE;
|
expr = create_character_initializer (init, last_ts, ref, rvalue);
|
expr = create_character_initializer (init, last_ts, ref, rvalue);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Overwriting an existing initializer is non-standard but usually only
|
/* Overwriting an existing initializer is non-standard but usually only
|
provokes a warning from other compilers. */
|
provokes a warning from other compilers. */
|
if (init != NULL)
|
if (init != NULL)
|
{
|
{
|
/* Order in which the expressions arrive here depends on whether
|
/* Order in which the expressions arrive here depends on whether
|
they are from data statements or F95 style declarations.
|
they are from data statements or F95 style declarations.
|
Therefore, check which is the most recent. */
|
Therefore, check which is the most recent. */
|
expr = (LOCATION_LINE (init->where.lb->location)
|
expr = (LOCATION_LINE (init->where.lb->location)
|
> LOCATION_LINE (rvalue->where.lb->location))
|
> LOCATION_LINE (rvalue->where.lb->location))
|
? init : rvalue;
|
? init : rvalue;
|
if (gfc_notify_std (GFC_STD_GNU,"Extension: "
|
if (gfc_notify_std (GFC_STD_GNU,"Extension: "
|
"re-initialization of '%s' at %L",
|
"re-initialization of '%s' at %L",
|
symbol->name, &expr->where) == FAILURE)
|
symbol->name, &expr->where) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
expr = gfc_copy_expr (rvalue);
|
expr = gfc_copy_expr (rvalue);
|
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
|
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
|
gfc_convert_type (expr, &lvalue->ts, 0);
|
gfc_convert_type (expr, &lvalue->ts, 0);
|
}
|
}
|
|
|
if (last_con == NULL)
|
if (last_con == NULL)
|
symbol->value = expr;
|
symbol->value = expr;
|
else
|
else
|
last_con->expr = expr;
|
last_con->expr = expr;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
|
|
abort:
|
abort:
|
mpz_clear (offset);
|
mpz_clear (offset);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Modify the index of array section and re-calculate the array offset. */
|
/* Modify the index of array section and re-calculate the array offset. */
|
|
|
void
|
void
|
gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
|
gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
|
mpz_t *offset_ret)
|
mpz_t *offset_ret)
|
{
|
{
|
int i;
|
int i;
|
mpz_t delta;
|
mpz_t delta;
|
mpz_t tmp;
|
mpz_t tmp;
|
bool forwards;
|
bool forwards;
|
int cmp;
|
int cmp;
|
|
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
if (ar->dimen_type[i] != DIMEN_RANGE)
|
if (ar->dimen_type[i] != DIMEN_RANGE)
|
continue;
|
continue;
|
|
|
if (ar->stride[i])
|
if (ar->stride[i])
|
{
|
{
|
mpz_add (section_index[i], section_index[i],
|
mpz_add (section_index[i], section_index[i],
|
ar->stride[i]->value.integer);
|
ar->stride[i]->value.integer);
|
if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
|
if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
|
forwards = true;
|
forwards = true;
|
else
|
else
|
forwards = false;
|
forwards = false;
|
}
|
}
|
else
|
else
|
{
|
{
|
mpz_add_ui (section_index[i], section_index[i], 1);
|
mpz_add_ui (section_index[i], section_index[i], 1);
|
forwards = true;
|
forwards = true;
|
}
|
}
|
|
|
if (ar->end[i])
|
if (ar->end[i])
|
cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
|
cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
|
else
|
else
|
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
|
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
|
|
|
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
|
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
|
{
|
{
|
/* Reset index to start, then loop to advance the next index. */
|
/* Reset index to start, then loop to advance the next index. */
|
if (ar->start[i])
|
if (ar->start[i])
|
mpz_set (section_index[i], ar->start[i]->value.integer);
|
mpz_set (section_index[i], ar->start[i]->value.integer);
|
else
|
else
|
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
|
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
|
}
|
}
|
else
|
else
|
break;
|
break;
|
}
|
}
|
|
|
mpz_set_si (*offset_ret, 0);
|
mpz_set_si (*offset_ret, 0);
|
mpz_init_set_si (delta, 1);
|
mpz_init_set_si (delta, 1);
|
mpz_init (tmp);
|
mpz_init (tmp);
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
|
mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
|
mpz_mul (tmp, tmp, delta);
|
mpz_mul (tmp, tmp, delta);
|
mpz_add (*offset_ret, tmp, *offset_ret);
|
mpz_add (*offset_ret, tmp, *offset_ret);
|
|
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
ar->as->lower[i]->value.integer);
|
ar->as->lower[i]->value.integer);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_mul (delta, tmp, delta);
|
mpz_mul (delta, tmp, delta);
|
}
|
}
|
mpz_clear (tmp);
|
mpz_clear (tmp);
|
mpz_clear (delta);
|
mpz_clear (delta);
|
}
|
}
|
|
|
|
|
/* Rearrange a structure constructor so the elements are in the specified
|
/* Rearrange a structure constructor so the elements are in the specified
|
order. Also insert NULL entries if necessary. */
|
order. Also insert NULL entries if necessary. */
|
|
|
static void
|
static void
|
formalize_structure_cons (gfc_expr *expr)
|
formalize_structure_cons (gfc_expr *expr)
|
{
|
{
|
gfc_constructor_base base = NULL;
|
gfc_constructor_base base = NULL;
|
gfc_constructor *cur;
|
gfc_constructor *cur;
|
gfc_component *order;
|
gfc_component *order;
|
|
|
/* Constructor is already formalized. */
|
/* Constructor is already formalized. */
|
cur = gfc_constructor_first (expr->value.constructor);
|
cur = gfc_constructor_first (expr->value.constructor);
|
if (!cur || cur->n.component == NULL)
|
if (!cur || cur->n.component == NULL)
|
return;
|
return;
|
|
|
for (order = expr->ts.u.derived->components; order; order = order->next)
|
for (order = expr->ts.u.derived->components; order; order = order->next)
|
{
|
{
|
cur = find_con_by_component (order, expr->value.constructor);
|
cur = find_con_by_component (order, expr->value.constructor);
|
if (cur)
|
if (cur)
|
gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
|
gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
|
else
|
else
|
gfc_constructor_append_expr (&base, NULL, NULL);
|
gfc_constructor_append_expr (&base, NULL, NULL);
|
}
|
}
|
|
|
/* For all what it's worth, one would expect
|
/* For all what it's worth, one would expect
|
gfc_constructor_free (expr->value.constructor);
|
gfc_constructor_free (expr->value.constructor);
|
here. However, if the constructor is actually free'd,
|
here. However, if the constructor is actually free'd,
|
hell breaks loose in the testsuite?! */
|
hell breaks loose in the testsuite?! */
|
|
|
expr->value.constructor = base;
|
expr->value.constructor = base;
|
}
|
}
|
|
|
|
|
/* Make sure an initialization expression is in normalized form, i.e., all
|
/* Make sure an initialization expression is in normalized form, i.e., all
|
elements of the constructors are in the correct order. */
|
elements of the constructors are in the correct order. */
|
|
|
static void
|
static void
|
formalize_init_expr (gfc_expr *expr)
|
formalize_init_expr (gfc_expr *expr)
|
{
|
{
|
expr_t type;
|
expr_t type;
|
gfc_constructor *c;
|
gfc_constructor *c;
|
|
|
if (expr == NULL)
|
if (expr == NULL)
|
return;
|
return;
|
|
|
type = expr->expr_type;
|
type = expr->expr_type;
|
switch (type)
|
switch (type)
|
{
|
{
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
for (c = gfc_constructor_first (expr->value.constructor);
|
for (c = gfc_constructor_first (expr->value.constructor);
|
c; c = gfc_constructor_next (c))
|
c; c = gfc_constructor_next (c))
|
formalize_init_expr (c->expr);
|
formalize_init_expr (c->expr);
|
|
|
break;
|
break;
|
|
|
case EXPR_STRUCTURE:
|
case EXPR_STRUCTURE:
|
formalize_structure_cons (expr);
|
formalize_structure_cons (expr);
|
break;
|
break;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Resolve symbol's initial value after all data statement. */
|
/* Resolve symbol's initial value after all data statement. */
|
|
|
void
|
void
|
gfc_formalize_init_value (gfc_symbol *sym)
|
gfc_formalize_init_value (gfc_symbol *sym)
|
{
|
{
|
formalize_init_expr (sym->value);
|
formalize_init_expr (sym->value);
|
}
|
}
|
|
|
|
|
/* Get the integer value into RET_AS and SECTION from AS and AR, and return
|
/* Get the integer value into RET_AS and SECTION from AS and AR, and return
|
offset. */
|
offset. */
|
|
|
void
|
void
|
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
|
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
|
{
|
{
|
int i;
|
int i;
|
mpz_t delta;
|
mpz_t delta;
|
mpz_t tmp;
|
mpz_t tmp;
|
|
|
mpz_set_si (*offset, 0);
|
mpz_set_si (*offset, 0);
|
mpz_init (tmp);
|
mpz_init (tmp);
|
mpz_init_set_si (delta, 1);
|
mpz_init_set_si (delta, 1);
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
mpz_init (section_index[i]);
|
mpz_init (section_index[i]);
|
switch (ar->dimen_type[i])
|
switch (ar->dimen_type[i])
|
{
|
{
|
case DIMEN_ELEMENT:
|
case DIMEN_ELEMENT:
|
case DIMEN_RANGE:
|
case DIMEN_RANGE:
|
if (ar->start[i])
|
if (ar->start[i])
|
{
|
{
|
mpz_sub (tmp, ar->start[i]->value.integer,
|
mpz_sub (tmp, ar->start[i]->value.integer,
|
ar->as->lower[i]->value.integer);
|
ar->as->lower[i]->value.integer);
|
mpz_mul (tmp, tmp, delta);
|
mpz_mul (tmp, tmp, delta);
|
mpz_add (*offset, tmp, *offset);
|
mpz_add (*offset, tmp, *offset);
|
mpz_set (section_index[i], ar->start[i]->value.integer);
|
mpz_set (section_index[i], ar->start[i]->value.integer);
|
}
|
}
|
else
|
else
|
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
|
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
|
break;
|
break;
|
|
|
case DIMEN_VECTOR:
|
case DIMEN_VECTOR:
|
gfc_internal_error ("TODO: Vector sections in data statements");
|
gfc_internal_error ("TODO: Vector sections in data statements");
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
mpz_sub (tmp, ar->as->upper[i]->value.integer,
|
ar->as->lower[i]->value.integer);
|
ar->as->lower[i]->value.integer);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_add_ui (tmp, tmp, 1);
|
mpz_mul (delta, tmp, delta);
|
mpz_mul (delta, tmp, delta);
|
}
|
}
|
|
|
mpz_clear (tmp);
|
mpz_clear (tmp);
|
mpz_clear (delta);
|
mpz_clear (delta);
|
}
|
}
|
|
|
|
|
