blob: 7a5866f3c288e8a74e13a8f425a24c44078197a4 [file] [log] [blame]
/* Supporting functions for resolving DATA statement.
Copyright (C) 2002-2022 Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
This file is part of GCC.
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
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* Notes for DATA statement implementation:
We first assign initial value to each symbol by gfc_assign_data_value
during resolving DATA statement. Refer to check_data_variable and
traverse_data_list in resolve.cc.
The complexity exists in the handling of array section, implied do
and array of struct appeared in DATA statement.
We call gfc_conv_structure, gfc_con_array_array_initializer,
etc., to convert the initial value. Refer to trans-expr.cc and
trans-array.cc. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
#include "data.h"
#include "constructor.h"
static void formalize_init_expr (gfc_expr *);
/* Calculate the array element offset. */
static void
get_array_index (gfc_array_ref *ar, mpz_t *offset)
{
gfc_expr *e;
int i;
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]);
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);
gfc_free_expr (e);
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);
}
/* Find if there is a constructor which component is equal to COM.
TODO: remove this, use symbol.cc(gfc_find_component) instead. */
static gfc_constructor *
find_con_by_component (gfc_component *com, gfc_constructor_base base)
{
gfc_constructor *c;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
if (com == c->n.component)
return c;
return NULL;
}
/* Create a character type initialization expression from RVALUE.
TS [and REF] describe [the substring of] the variable being initialized.
INIT is the existing initializer, not NULL. Initialization is performed
according to normal assignment rules. */
static gfc_expr *
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
HOST_WIDE_INT len, start, end, tlen;
gfc_char_t *dest;
bool alloced_init = false;
if (init && init->ts.type != BT_CHARACTER)
return NULL;
gfc_extract_hwi (ts->u.cl->length, &len);
if (init == NULL)
{
/* Create a new initializer. */
init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
init->ts = *ts;
alloced_init = true;
}
dest = init->value.character.string;
if (ref)
{
gfc_expr *start_expr, *end_expr;
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((!gfc_simplify_expr(start_expr, 1))
|| !(gfc_simplify_expr(end_expr, 1)))
{
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
gfc_free_expr (start_expr);
gfc_free_expr (end_expr);
if (alloced_init)
gfc_free_expr (init);
return NULL;
}
gfc_extract_hwi (start_expr, &start);
gfc_free_expr (start_expr);
start--;
gfc_extract_hwi (end_expr, &end);
gfc_free_expr (end_expr);
}
else
{
/* Set the whole string. */
start = 0;
end = len;
}
/* Copy the initial value. */
if (rvalue->ts.type == BT_HOLLERITH)
len = rvalue->representation.length - rvalue->ts.u.pad;
else
len = rvalue->value.character.length;
tlen = end - start;
if (len > tlen)
{
if (tlen < 0)
{
gfc_warning_now (0, "Unused initialization string at %L because "
"variable has zero length", &rvalue->where);
len = 0;
}
else
{
gfc_warning_now (0, "Initialization string at %L was truncated to "
"fit the variable (%ld/%ld)", &rvalue->where,
(long) tlen, (long) len);
len = tlen;
}
}
if (start < 0)
{
gfc_error ("Substring start index at %L is less than one",
&ref->u.ss.start->where);
return NULL;
}
if (end > init->value.character.length)
{
gfc_error ("Substring end index at %L exceeds the string length",
&ref->u.ss.end->where);
return NULL;
}
if (rvalue->ts.type == BT_HOLLERITH)
{
for (size_t i = 0; i < (size_t) len; i++)
dest[start+i] = rvalue->representation.string[i];
}
else
memcpy (&dest[start], rvalue->value.character.string,
len * sizeof (gfc_char_t));
/* Pad with spaces. Substrings will already be blanked. */
if (len < tlen && ref == NULL)
gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH)
{
init->representation.length = init->value.character.length;
init->representation.string
= gfc_widechar_to_char (init->value.character.string,
init->value.character.length);
}
return init;
}
/* 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. 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. */
bool
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
mpz_t *repeat)
{
gfc_ref *ref;
gfc_expr *init;
gfc_expr *expr = NULL;
gfc_expr *rexpr;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
const char *msg = "F18(R841): data-implied-do object at %L is neither an "
"array-element nor a scalar-structure-component";
symbol = lvalue->symtree->n.sym;
if (symbol->attr.flavor == FL_PARAMETER)
{
gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %L",
symbol->name, &lvalue->where);
return false;
}
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)
{
/* Break out of the loop if we find a substring. */
if (ref->type == REF_SUBSTRING)
{
/* A substring should always be the last subobject reference. */
gcc_assert (ref->next == NULL);
break;
}
/* 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 (ref->u.ar.as->rank == 0)
{
gcc_assert (ref->u.ar.as->corank > 0);
if (init == NULL)
free (expr);
continue;
}
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("%qs at %L already is initialized at %L",
lvalue->symtree->n.sym->name, &lvalue->where,
&init->where);
goto abort;
}
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;
}
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
/* Check the bounds. */
if (mpz_cmp_si (offset, 0) < 0)
{
gfc_error ("Data element below array lower bound at %L",
&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))
{
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,
"re-initialization of %qs at %L",
symbol->name, &exprd->where) == false)
return false;
}
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;
if (spec_size (ref->u.ar.as, &size))
{
if (mpz_cmp (offset, 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_insert_expr (&expr->value.constructor,
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:
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;
}
break;
case REF_INQUIRY:
/* After some discussion on clf it was determined that the following
violates F18(R841). If the error is removed, the expected result
is obtained. Leaving the code in place ensures a clean error
recovery. */
gfc_error (msg, &lvalue->where);
/* This breaks with the other reference types in that the output
constructor has to be of type COMPLEX, whereas the lvalue is
of type REAL. The rvalue is copied to the real or imaginary
part as appropriate. In addition, for all except scalar
complex variables, a complex expression has to provided, where
the constructor does not have it, and the expression modified
with a new value for the real or imaginary part. */
gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX);
rexpr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &rexpr->ts))
gfc_convert_type (rexpr, &lvalue->ts, 0);
/* This is the scalar, complex case, where an initializer exists. */
if (init && ref == lvalue->ref)
expr = symbol->value;
/* Then all cases, where a complex expression does not exist. */
else if (!last_con || !last_con->expr)
{
expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind,
&lvalue->where);
if (last_con)
last_con->expr = expr;
}
else
/* Finally, and existing constructor expression to be modified. */
expr = last_con->expr;
/* Rejection of LEN and KIND inquiry references is handled
elsewhere. The error here is added as backup. The assertion
of F2008 for RE and IM is also done elsewhere. */
switch (ref->u.i)
{
case INQUIRY_LEN:
case INQUIRY_KIND:
gfc_error ("LEN or KIND inquiry ref in DATA statement at %L",
&lvalue->where);
goto abort;
case INQUIRY_RE:
mpfr_set (mpc_realref (expr->value.complex),
rexpr->value.real,
GFC_RND_MODE);
break;
case INQUIRY_IM:
mpfr_set (mpc_imagref (expr->value.complex),
rexpr->value.real,
GFC_RND_MODE);
break;
}
/* Only the scalar, complex expression needs to be saved as the
symbol value since the last constructor expression is already
provided as the initializer in the code after the reference
cases. */
if (ref == lvalue->ref)
symbol->value = expr;
gfc_free_expr (rexpr);
mpz_clear (offset);
return true;
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_clear (offset);
gcc_assert (repeat == NULL);
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
if (init != NULL && init->where.lb && rvalue->where.lb)
{
/* 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. */
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
symbol->name, &expr->where) == false)
return false;
}
if (ref || (last_ts->type == BT_CHARACTER
&& rvalue->expr_type == EXPR_CONSTANT))
{
/* An initializer has to be constant. */
if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
return false;
if (lvalue->ts.u.cl->length
&& lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return false;
expr = create_character_initializer (init, last_ts, ref, rvalue);
if (!expr)
return false;
}
else
{
if (lvalue->ts.type == BT_DERIVED
&& gfc_has_default_initializer (lvalue->ts.u.derived))
{
gfc_error ("Nonpointer object %qs with default initialization "
"shall not appear in a DATA statement at %L",
symbol->name, &lvalue->where);
return false;
}
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (IS_POINTER (symbol)
&& !gfc_check_pointer_assign (lvalue, rvalue, false, true))
return false;
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
return true;
abort:
if (!init)
gfc_free_expr (expr);
mpz_clear (offset);
return false;
}
/* Modify the index of array section and re-calculate the array offset. */
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;
gfc_expr *start, *end, *stride;
for (i = 0; i < ar->dimen; i++)
{
if (ar->dimen_type[i] != DIMEN_RANGE)
continue;
if (ar->stride[i])
{
stride = gfc_copy_expr(ar->stride[i]);
if(!gfc_simplify_expr(stride, 1))
gfc_internal_error("Simplification error");
mpz_add (section_index[i], section_index[i],
stride->value.integer);
if (mpz_cmp_si (stride->value.integer, 0) >= 0)
forwards = true;
else
forwards = false;
gfc_free_expr(stride);
}
else
{
mpz_add_ui (section_index[i], section_index[i], 1);
forwards = true;
}
if (ar->end[i])
{
end = gfc_copy_expr(ar->end[i]);
if(!gfc_simplify_expr(end, 1))
gfc_internal_error("Simplification error");
cmp = mpz_cmp (section_index[i], end->value.integer);
gfc_free_expr(end);
}
else
cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
{
/* Reset index to start, then loop to advance the next index. */
if (ar->start[i])
{
start = gfc_copy_expr(ar->start[i]);
if(!gfc_simplify_expr(start, 1))
gfc_internal_error("Simplification error");
mpz_set (section_index[i], start->value.integer);
gfc_free_expr(start);
}
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);
}
/* Rearrange a structure constructor so the elements are in the specified
order. Also insert NULL entries if necessary. */
static void
formalize_structure_cons (gfc_expr *expr)
{
gfc_constructor_base base = NULL;
gfc_constructor *cur;
gfc_component *order;
/* Constructor is already formalized. */
cur = gfc_constructor_first (expr->value.constructor);
if (!cur || cur->n.component == NULL)
return;
for (order = expr->ts.u.derived->components; order; order = order->next)
{
cur = find_con_by_component (order, expr->value.constructor);
if (cur)
gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
else
gfc_constructor_append_expr (&base, NULL, NULL);
}
/* For all what it's worth, one would expect
gfc_constructor_free (expr->value.constructor);
here. However, if the constructor is actually free'd,
hell breaks loose in the testsuite?! */
expr->value.constructor = base;
}
/* Make sure an initialization expression is in normalized form, i.e., all
elements of the constructors are in the correct order. */
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:
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c))
formalize_init_expr (c->expr);
break;
case EXPR_STRUCTURE:
formalize_structure_cons (expr);
break;
default:
break;
}
}
/* Resolve symbol's initial value after all data statement. */
void
gfc_formalize_init_value (gfc_symbol *sym)
{
formalize_init_expr (sym->value);
}
/* Get the integer value into RET_AS and SECTION from AS and AR, and return
offset. */
void
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
{
int i;
mpz_t delta;
mpz_t tmp;
gfc_expr *start;
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])
{
start = gfc_copy_expr(ar->start[i]);
if(!gfc_simplify_expr(start, 1))
gfc_internal_error("Simplification error");
mpz_sub (tmp, start->value.integer,
ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_set (section_index[i], start->value.integer);
gfc_free_expr(start);
}
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
break;
case DIMEN_VECTOR:
gfc_internal_error ("TODO: Vector sections in data statements");
default:
gcc_unreachable ();
}
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);
}