/* Supporting functions for resolving DATA statement.
- Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 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 2, or (at your option)
-any later version.
+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.
-GNU G95 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.
+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 GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+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 resolveing DATA statement. Refer to check_data_variable and
+ during resolving DATA statement. Refer to check_data_variable and
traverse_data_list in resolve.c.
-
- The complexity exists in the handleing of array section, implied do
+
+ 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.c and
trans-array.c. */
#include "config.h"
#include "system.h"
-#include "coretypes.h"
-#include "toplev.h"
#include "gfortran.h"
-#include "assert.h"
-#include "trans.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)
+get_array_index (gfc_array_ref *ar, mpz_t *offset)
{
gfc_expr *e;
int i;
- try re;
mpz_t delta;
mpz_t tmp;
for (i = 0; i < ar->dimen; i++)
{
e = gfc_copy_expr (ar->start[i]);
- re = gfc_simplify_expr (e, 1);
+ 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);
+ gfc_error ("non-constant array in DATA statement %L", &ar->where);
+
mpz_set (tmp, e->value.integer);
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);
+ ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
mpz_clear (tmp);
}
-
-/* Find if there is a constructor which offset is equal to OFFSET. */
+/* Find if there is a constructor which component is equal to COM.
+ TODO: remove this, use symbol.c(gfc_find_component) instead. */
static gfc_constructor *
-find_con_by_offset (mpz_t offset, gfc_constructor *con)
+find_con_by_component (gfc_component *com, gfc_constructor_base base)
{
- for (; con; con = con->next)
- {
- if (mpz_cmp (offset, con->n.offset) == 0)
- return con;
- }
+ gfc_constructor *c;
+
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ if (com == c->n.component)
+ return c;
+
return NULL;
}
-/* Find if there is a constructor which component is equal to COM. */
+/* 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_constructor *
-find_con_by_component (gfc_component *com, gfc_constructor *con)
+static gfc_expr *
+create_character_initializer (gfc_expr *init, gfc_typespec *ts,
+ gfc_ref *ref, gfc_expr *rvalue)
{
- for (; con; con = con->next)
+ int len, start, end;
+ gfc_char_t *dest;
+
+ gfc_extract_int (ts->u.cl->length, &len);
+
+ if (init == NULL)
{
- if (com == con->n.component)
- return con;
+ /* Create a new initializer. */
+ init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
+ init->ts = *ts;
}
- return NULL;
+
+ 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) == FAILURE)
+ || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
+ {
+ gfc_error ("failure to simplify substring reference in DATA "
+ "statement at %L", &ref->u.ss.start->where);
+ return NULL;
+ }
+
+ gfc_extract_int (start_expr, &start);
+ start--;
+ gfc_extract_int (end_expr, &end);
+ }
+ 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;
+
+ if (len > end - start)
+ {
+ gfc_warning_now ("Initialization string starting at %L was "
+ "truncated to fit the variable (%d/%d)",
+ &rvalue->where, end - start, len);
+ len = end - start;
+ }
+
+ if (rvalue->ts.type == BT_HOLLERITH)
+ {
+ int i;
+ for (i = 0; i < 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 < end - start && 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. */
-void
-gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
+/* 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. */
+
+gfc_try
+gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
{
gfc_ref *ref;
gfc_expr *init;
gfc_constructor *con;
gfc_constructor *last_con;
gfc_symbol *symbol;
+ gfc_typespec *last_ts;
mpz_t offset;
- ref = lvalue->ref;
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)
{
+ /* 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. */
+ create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.as->rank == 0)
+ {
+ gcc_assert (ref->u.ar.as->corank > 0);
+ if (init == NULL)
+ gfc_free (expr);
+ continue;
+ }
+
+ if (init && expr->expr_type != EXPR_ARRAY)
+ {
+ gfc_error ("'%s' 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;
- if (ref->next)
- {
- assert (ref->next->type == REF_COMPONENT);
- expr->ts.type = BT_DERIVED;
- }
- else
- expr->ts = rvalue->ts;
expr->rank = ref->u.ar.as->rank;
}
- else
- assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
get_array_index (&ref->u.ar, &offset);
else
mpz_set (offset, index);
- /* Find the same element in the existing constructor. */
- con = expr->value.constructor;
- con = find_con_by_offset (offset, con);
+ /* 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
+ {
+ mpz_t size;
+ if (spec_size (ref->u.ar.as, &size) == SUCCESS)
+ {
+ 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);
+ }
+ }
- if (con == NULL)
+ con = gfc_constructor_lookup (expr->value.constructor,
+ mpz_get_si (offset));
+ if (!con)
{
- /* Create a new constructor. */
- con = gfc_get_constructor();
- mpz_set (con->n.offset, offset);
- gfc_insert_constructor (expr, con);
+ con = gfc_constructor_insert_expr (&expr->value.constructor,
+ NULL, &rvalue->where,
+ mpz_get_si (offset));
}
break;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
- expr->ts.derived = ref->u.c.sym;
+ expr->ts.u.derived = ref->u.c.sym;
}
else
- assert (expr->expr_type == EXPR_STRUCTURE);
+ gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+ last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
- con = expr->value.constructor;
- con = find_con_by_component (ref->u.c.component, con);
+ con = find_con_by_component (ref->u.c.component,
+ expr->value.constructor);
if (con == NULL)
{
/* Create a new constructor. */
- con = gfc_get_constructor ();
+ con = gfc_constructor_append_expr (&expr->value.constructor,
+ NULL, NULL);
con->n.component = ref->u.c.component;
- con->next = expr->value.constructor;
- expr->value.constructor = con;
}
break;
- case REF_SUBSTRING:
- gfc_todo_error ("Substring reference in DATA statement");
-
default:
- abort ();
+ gcc_unreachable ();
}
if (init == NULL)
last_con = con;
}
- expr = gfc_copy_expr (rvalue);
- if (!gfc_compare_types (&lvalue->ts, &expr->ts))
- gfc_convert_type (expr, &lvalue->ts, 0);
+ mpz_clear (offset);
- if (last_con == NULL)
- symbol->value = expr;
+ if (ref || last_ts->type == BT_CHARACTER)
+ {
+ if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
+ return FAILURE;
+ expr = create_character_initializer (init, last_ts, ref, rvalue);
+ }
else
{
- assert (!last_con->expr);
- last_con->expr = expr;
+ /* Overwriting an existing initializer is non-standard but usually only
+ provokes a warning from other compilers. */
+ if (init != 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. */
+ expr = (LOCATION_LINE (init->where.lb->location)
+ > LOCATION_LINE (rvalue->where.lb->location))
+ ? init : rvalue;
+ 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);
+ 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 SUCCESS;
+
+abort:
+ mpz_clear (offset);
+ return FAILURE;
+}
+
+
+/* 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;
}
else
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])
mpz_set (section_index[i], ar->start[i]->value.integer);
else
mpz_add (*offset_ret, tmp, *offset_ret);
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_mul (delta, tmp, delta);
}
/* Rearrange a structure constructor so the elements are in the specified
- order. Also insert NULL entries if neccessary. */
+ order. Also insert NULL entries if necessary. */
static void
-formalize_structure_cons (gfc_expr * expr)
+formalize_structure_cons (gfc_expr *expr)
{
- gfc_constructor *head;
- gfc_constructor *tail;
+ gfc_constructor_base base = NULL;
gfc_constructor *cur;
- gfc_constructor *last;
- gfc_constructor *c;
gfc_component *order;
- c = expr->value.constructor;
-
- /* Constructor is already fomalized. */
- if (c->n.component == NULL)
+ /* Constructor is already formalized. */
+ cur = gfc_constructor_first (expr->value.constructor);
+ if (!cur || cur->n.component == NULL)
return;
- head = tail = NULL;
- for (order = expr->ts.derived->components; order; order = order->next)
+ for (order = expr->ts.u.derived->components; order; order = order->next)
{
- /* Find the next component. */
- last = NULL;
- cur = c;
- while (cur != NULL && cur->n.component != order)
- {
- last = cur;
- cur = cur->next;
- }
-
- if (cur == NULL)
- {
- /* Create a new one. */
- cur = gfc_get_constructor ();
- }
+ cur = find_con_by_component (order, expr->value.constructor);
+ if (cur)
+ gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
else
- {
- /* Remove it from the chain. */
- if (last == NULL)
- c = cur->next;
- else
- last->next = cur->next;
- cur->next = NULL;
+ gfc_constructor_append_expr (&base, NULL, NULL);
+ }
- formalize_init_expr (cur->expr);
- }
+ /* 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?! */
- /* Add it to the new constructor. */
- if (head == NULL)
- head = tail = cur;
- else
- {
- tail->next = cur;
- tail = tail->next;
- }
- }
- assert (c == NULL);
- expr->value.constructor = head;
+ expr->value.constructor = base;
}
-/* Make sure an initialization expression is in normalized form. Ie. all
+/* 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)
+formalize_init_expr (gfc_expr *expr)
{
expr_t type;
gfc_constructor *c;
switch (type)
{
case EXPR_ARRAY:
- c = expr->value.constructor;
- while (c)
- {
- formalize_init_expr (c->expr);
- c = c->next;
- }
- break;
+ 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;
case DIMEN_VECTOR:
- gfc_todo_error ("Vectors sections in data statements");
+ gfc_internal_error ("TODO: Vector sections in data statements");
default:
- abort ();
+ gcc_unreachable ();
}
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_mul (delta, tmp, delta);
}