1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Lifang Zeng <zlf605@hotmail.com>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Notes for DATA statement implementation:
25 We first assign initial value to each symbol by gfc_assign_data_value
26 during resolving DATA statement. Refer to check_data_variable and
27 traverse_data_list in resolve.c.
29 The complexity exists in the handling of array section, implied do
30 and array of struct appeared in DATA statement.
32 We call gfc_conv_structure, gfc_con_array_array_initializer,
33 etc., to convert the initial value. Refer to trans-expr.c and
39 #include "constructor.h"
41 static void formalize_init_expr (gfc_expr *);
43 /* Calculate the array element offset. */
46 get_array_index (gfc_array_ref *ar, mpz_t *offset)
54 mpz_set_si (*offset, 0);
55 mpz_init_set_si (delta, 1);
56 for (i = 0; i < ar->dimen; i++)
58 e = gfc_copy_expr (ar->start[i]);
59 gfc_simplify_expr (e, 1);
61 if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
62 || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
63 || (gfc_is_constant_expr (e) == 0))
64 gfc_error ("non-constant array in DATA statement %L", &ar->where);
66 mpz_set (tmp, e->value.integer);
67 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
68 mpz_mul (tmp, tmp, delta);
69 mpz_add (*offset, tmp, *offset);
71 mpz_sub (tmp, ar->as->upper[i]->value.integer,
72 ar->as->lower[i]->value.integer);
73 mpz_add_ui (tmp, tmp, 1);
74 mpz_mul (delta, tmp, delta);
80 /* Find if there is a constructor which component is equal to COM.
81 TODO: remove this, use symbol.c(gfc_find_component) instead. */
83 static gfc_constructor *
84 find_con_by_component (gfc_component *com, gfc_constructor_base base)
88 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
89 if (com == c->n.component)
96 /* Create a character type initialization expression from RVALUE.
97 TS [and REF] describe [the substring of] the variable being initialized.
98 INIT is the existing initializer, not NULL. Initialization is performed
99 according to normal assignment rules. */
102 create_character_intializer (gfc_expr *init, gfc_typespec *ts,
103 gfc_ref *ref, gfc_expr *rvalue)
108 gfc_extract_int (ts->u.cl->length, &len);
112 /* Create a new initializer. */
113 init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
117 dest = init->value.character.string;
121 gfc_expr *start_expr, *end_expr;
123 gcc_assert (ref->type == REF_SUBSTRING);
125 /* Only set a substring of the destination. Fortran substring bounds
126 are one-based [start, end], we want zero based [start, end). */
127 start_expr = gfc_copy_expr (ref->u.ss.start);
128 end_expr = gfc_copy_expr (ref->u.ss.end);
130 if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
131 || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
133 gfc_error ("failure to simplify substring reference in DATA "
134 "statement at %L", &ref->u.ss.start->where);
138 gfc_extract_int (start_expr, &start);
140 gfc_extract_int (end_expr, &end);
144 /* Set the whole string. */
149 /* Copy the initial value. */
150 if (rvalue->ts.type == BT_HOLLERITH)
151 len = rvalue->representation.length;
153 len = rvalue->value.character.length;
155 if (len > end - start)
157 gfc_warning_now ("Initialization string starting at %L was "
158 "truncated to fit the variable (%d/%d)",
159 &rvalue->where, end - start, len);
163 if (rvalue->ts.type == BT_HOLLERITH)
166 for (i = 0; i < len; i++)
167 dest[start+i] = rvalue->representation.string[i];
170 memcpy (&dest[start], rvalue->value.character.string,
171 len * sizeof (gfc_char_t));
173 /* Pad with spaces. Substrings will already be blanked. */
174 if (len < end - start && ref == NULL)
175 gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
177 if (rvalue->ts.type == BT_HOLLERITH)
179 init->representation.length = init->value.character.length;
180 init->representation.string
181 = gfc_widechar_to_char (init->value.character.string,
182 init->value.character.length);
189 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
190 LVALUE already has an initialization, we extend this, otherwise we
194 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
199 gfc_constructor *con;
200 gfc_constructor *last_con;
202 gfc_typespec *last_ts;
205 symbol = lvalue->symtree->n.sym;
206 init = symbol->value;
207 last_ts = &symbol->ts;
209 mpz_init_set_si (offset, 0);
211 /* Find/create the parent expressions for subobject references. */
212 for (ref = lvalue->ref; ref; ref = ref->next)
214 /* Break out of the loop if we find a substring. */
215 if (ref->type == REF_SUBSTRING)
217 /* A substring should always be the last subobject reference. */
218 gcc_assert (ref->next == NULL);
222 /* Use the existing initializer expression if it exists. Otherwise
225 expr = gfc_get_expr ();
229 /* Find or create this element. */
233 if (ref->u.ar.as->rank == 0)
235 gcc_assert (ref->u.ar.as->corank > 0);
241 if (init && expr->expr_type != EXPR_ARRAY)
243 gfc_error ("'%s' at %L already is initialized at %L",
244 lvalue->symtree->n.sym->name, &lvalue->where,
251 /* The element typespec will be the same as the array
254 /* Setup the expression to hold the constructor. */
255 expr->expr_type = EXPR_ARRAY;
256 expr->rank = ref->u.ar.as->rank;
259 if (ref->u.ar.type == AR_ELEMENT)
260 get_array_index (&ref->u.ar, &offset);
262 mpz_set (offset, index);
264 /* Check the bounds. */
265 if (mpz_cmp_si (offset, 0) < 0)
267 gfc_error ("Data element below array lower bound at %L",
274 if (spec_size (ref->u.ar.as, &size) == SUCCESS)
276 if (mpz_cmp (offset, size) >= 0)
279 gfc_error ("Data element above array upper bound at %L",
287 con = gfc_constructor_lookup (expr->value.constructor,
288 mpz_get_si (offset));
291 con = gfc_constructor_insert_expr (&expr->value.constructor,
292 NULL, &rvalue->where,
293 mpz_get_si (offset));
300 /* Setup the expression to hold the constructor. */
301 expr->expr_type = EXPR_STRUCTURE;
302 expr->ts.type = BT_DERIVED;
303 expr->ts.u.derived = ref->u.c.sym;
306 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
307 last_ts = &ref->u.c.component->ts;
309 /* Find the same element in the existing constructor. */
310 con = find_con_by_component (ref->u.c.component,
311 expr->value.constructor);
315 /* Create a new constructor. */
316 con = gfc_constructor_append_expr (&expr->value.constructor,
318 con->n.component = ref->u.c.component;
328 /* Point the container at the new expression. */
329 if (last_con == NULL)
330 symbol->value = expr;
332 last_con->expr = expr;
338 if (ref || last_ts->type == BT_CHARACTER)
340 if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
342 expr = create_character_intializer (init, last_ts, ref, rvalue);
346 /* Overwriting an existing initializer is non-standard but usually only
347 provokes a warning from other compilers. */
350 /* Order in which the expressions arrive here depends on whether
351 they are from data statements or F95 style declarations.
352 Therefore, check which is the most recent. */
353 expr = (LOCATION_LINE (init->where.lb->location)
354 > LOCATION_LINE (rvalue->where.lb->location))
356 if (gfc_notify_std (GFC_STD_GNU,"Extension: "
357 "re-initialization of '%s' at %L",
358 symbol->name, &expr->where) == FAILURE)
362 expr = gfc_copy_expr (rvalue);
363 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
364 gfc_convert_type (expr, &lvalue->ts, 0);
367 if (last_con == NULL)
368 symbol->value = expr;
370 last_con->expr = expr;
376 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
380 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
381 mpz_t index, mpz_t repeat)
383 mpz_t offset, last_offset;
387 mpz_init (last_offset);
388 mpz_add (last_offset, index, repeat);
391 for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0;
392 mpz_add_ui (offset, offset, 1))
393 if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE)
400 mpz_clear (last_offset);
406 /* Modify the index of array section and re-calculate the array offset. */
409 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
418 for (i = 0; i < ar->dimen; i++)
420 if (ar->dimen_type[i] != DIMEN_RANGE)
425 mpz_add (section_index[i], section_index[i],
426 ar->stride[i]->value.integer);
427 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
434 mpz_add_ui (section_index[i], section_index[i], 1);
439 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
441 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
443 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
445 /* Reset index to start, then loop to advance the next index. */
447 mpz_set (section_index[i], ar->start[i]->value.integer);
449 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
455 mpz_set_si (*offset_ret, 0);
456 mpz_init_set_si (delta, 1);
458 for (i = 0; i < ar->dimen; i++)
460 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
461 mpz_mul (tmp, tmp, delta);
462 mpz_add (*offset_ret, tmp, *offset_ret);
464 mpz_sub (tmp, ar->as->upper[i]->value.integer,
465 ar->as->lower[i]->value.integer);
466 mpz_add_ui (tmp, tmp, 1);
467 mpz_mul (delta, tmp, delta);
474 /* Rearrange a structure constructor so the elements are in the specified
475 order. Also insert NULL entries if necessary. */
478 formalize_structure_cons (gfc_expr *expr)
480 gfc_constructor_base base = NULL;
481 gfc_constructor *cur;
482 gfc_component *order;
484 /* Constructor is already formalized. */
485 cur = gfc_constructor_first (expr->value.constructor);
486 if (!cur || cur->n.component == NULL)
489 for (order = expr->ts.u.derived->components; order; order = order->next)
491 cur = find_con_by_component (order, expr->value.constructor);
493 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
495 gfc_constructor_append_expr (&base, NULL, NULL);
498 /* For all what it's worth, one would expect
499 gfc_constructor_free (expr->value.constructor);
500 here. However, if the constructor is actually free'd,
501 hell breaks loose in the testsuite?! */
503 expr->value.constructor = base;
507 /* Make sure an initialization expression is in normalized form, i.e., all
508 elements of the constructors are in the correct order. */
511 formalize_init_expr (gfc_expr *expr)
519 type = expr->expr_type;
523 for (c = gfc_constructor_first (expr->value.constructor);
524 c; c = gfc_constructor_next (c))
525 formalize_init_expr (c->expr);
530 formalize_structure_cons (expr);
539 /* Resolve symbol's initial value after all data statement. */
542 gfc_formalize_init_value (gfc_symbol *sym)
544 formalize_init_expr (sym->value);
548 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
552 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
558 mpz_set_si (*offset, 0);
560 mpz_init_set_si (delta, 1);
561 for (i = 0; i < ar->dimen; i++)
563 mpz_init (section_index[i]);
564 switch (ar->dimen_type[i])
570 mpz_sub (tmp, ar->start[i]->value.integer,
571 ar->as->lower[i]->value.integer);
572 mpz_mul (tmp, tmp, delta);
573 mpz_add (*offset, tmp, *offset);
574 mpz_set (section_index[i], ar->start[i]->value.integer);
577 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
581 gfc_internal_error ("TODO: Vector sections in data statements");
587 mpz_sub (tmp, ar->as->upper[i]->value.integer,
588 ar->as->lower[i]->value.integer);
589 mpz_add_ui (tmp, tmp, 1);
590 mpz_mul (delta, tmp, delta);