diff options
Diffstat (limited to 'gcc/fortran/data.c')
| -rw-r--r-- | gcc/fortran/data.c | 697 |
1 files changed, 697 insertions, 0 deletions
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c new file mode 100644 index 000000000..0cbf67dc6 --- /dev/null +++ b/gcc/fortran/data.c @@ -0,0 +1,697 @@ +/* Supporting functions for resolving DATA statement. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 + 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.c. + + 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 "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); + 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.c(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) +{ + int len, start, end; + gfc_char_t *dest; + + gfc_extract_int (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; + } + + 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. 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. */ + +gfc_try +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; + gfc_constructor *con; + gfc_constructor *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) + { + /* 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) + 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; + 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) == 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; + 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); + } + } + + 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; + + 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); + + 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 + { + /* 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; +} + + +/* 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; + + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_RANGE) + continue; + + if (ar->stride[i]) + { + mpz_add (section_index[i], section_index[i], + ar->stride[i]->value.integer); + if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0) + forwards = true; + else + forwards = false; + } + else + { + mpz_add_ui (section_index[i], section_index[i], 1); + forwards = true; + } + + if (ar->end[i]) + cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer); + 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]) + mpz_set (section_index[i], ar->start[i]->value.integer); + 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; + + 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]) + { + mpz_sub (tmp, ar->start[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset, tmp, *offset); + mpz_set (section_index[i], ar->start[i]->value.integer); + } + 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); +} + |