/* Supporting functions for resolving DATA statement. Copyright (C) 2002-2022 Free Software Foundation, Inc. Contributed by Lifang Zeng 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 . */ /* 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); }