diff options
Diffstat (limited to 'gcc/fortran/data.cc')
-rw-r--r-- | gcc/fortran/data.cc | 848 |
1 files changed, 848 insertions, 0 deletions
diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc new file mode 100644 index 0000000..839e042 --- /dev/null +++ b/gcc/fortran/data.cc @@ -0,0 +1,848 @@ +/* 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.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 "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.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) +{ + 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 (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); +} + |