1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Lifang Zeng <zlf605@hotmail.com>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
23 /* Notes for DATA statement implementation:
25 We first assign initial value to each symbol by gfc_assign_data_value
26 during resolveing 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 static void formalize_init_expr (gfc_expr *);
41 /* Calculate the array element offset. */
44 get_array_index (gfc_array_ref * ar, mpz_t * offset)
53 mpz_set_si (*offset, 0);
54 mpz_init_set_si (delta, 1);
55 for (i = 0; i < ar->dimen; i++)
57 e = gfc_copy_expr (ar->start[i]);
58 re = gfc_simplify_expr (e, 1);
60 if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
61 || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
62 || (gfc_is_constant_expr (e) == 0))
63 gfc_error ("non-constant array in DATA statement %L.", &ar->where);
64 mpz_set (tmp, e->value.integer);
65 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
66 mpz_mul (tmp, tmp, delta);
67 mpz_add (*offset, tmp, *offset);
69 mpz_sub (tmp, ar->as->upper[i]->value.integer,
70 ar->as->lower[i]->value.integer);
71 mpz_add_ui (tmp, tmp, 1);
72 mpz_mul (delta, tmp, delta);
79 /* Find if there is a constructor which offset is equal to OFFSET. */
81 static gfc_constructor *
82 find_con_by_offset (mpz_t offset, gfc_constructor *con)
85 gfc_constructor *ret = NULL;
89 for (; con; con = con->next)
91 int cmp = mpz_cmp (offset, con->n.offset);
93 /* We retain a sorted list, so if we're too large, we're done. */
97 /* Yaye for exact matches. */
104 /* If the constructor element is a range, match any element. */
105 if (mpz_cmp_ui (con->repeat, 1) > 0)
107 mpz_add (tmp, con->n.offset, con->repeat);
108 if (mpz_cmp (offset, tmp) < 0)
121 /* Find if there is a constructor which component is equal to COM. */
123 static gfc_constructor *
124 find_con_by_component (gfc_component *com, gfc_constructor *con)
126 for (; con; con = con->next)
128 if (com == con->n.component)
135 /* Create a character type initialization expression from RVALUE.
136 TS [and REF] describe [the substring of] the variable being initialized.
137 INIT is thh existing initializer, not NULL. Initialization is performed
138 according to normal assignment rules. */
141 create_character_intializer (gfc_expr * init, gfc_typespec * ts,
142 gfc_ref * ref, gfc_expr * rvalue)
149 gfc_extract_int (ts->cl->length, &len);
153 /* Create a new initializer. */
154 init = gfc_get_expr ();
155 init->expr_type = EXPR_CONSTANT;
158 dest = gfc_getmem (len);
159 init->value.character.length = len;
160 init->value.character.string = dest;
161 /* Blank the string if we're only setting a substring. */
163 memset (dest, ' ', len);
166 dest = init->value.character.string;
170 gcc_assert (ref->type == REF_SUBSTRING);
172 /* Only set a substring of the destination. Fortran substring bounds
173 are one-based [start, end], we want zero based [start, end). */
174 gfc_extract_int (ref->u.ss.start, &start);
176 gfc_extract_int (ref->u.ss.end, &end);
180 /* Set the whole string. */
185 /* Copy the initial value. */
186 len = rvalue->value.character.length;
187 if (len > end - start)
190 gfc_warning_now ("initialization string truncated to match variable "
191 "at %L", &rvalue->where);
194 memcpy (&dest[start], rvalue->value.character.string, len);
196 /* Pad with spaces. Substrings will already be blanked. */
197 if (len < end - start && ref == NULL)
198 memset (&dest[start + len], ' ', end - (start + len));
200 if (rvalue->ts.type == BT_HOLLERITH)
206 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
207 LVALUE already has an initialization, we extend this, otherwise we
211 gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
216 gfc_constructor *con;
217 gfc_constructor *last_con;
219 gfc_typespec *last_ts;
222 symbol = lvalue->symtree->n.sym;
223 init = symbol->value;
224 last_ts = &symbol->ts;
226 mpz_init_set_si (offset, 0);
228 /* Find/create the parent expressions for subobject references. */
229 for (ref = lvalue->ref; ref; ref = ref->next)
231 /* Break out of the loop if we find a substring. */
232 if (ref->type == REF_SUBSTRING)
234 /* A substring should always be the last subobject reference. */
235 gcc_assert (ref->next == NULL);
239 /* Use the existing initializer expression if it exists. Otherwise
242 expr = gfc_get_expr ();
246 /* Find or create this element. */
252 /* The element typespec will be the same as the array
255 /* Setup the expression to hold the constructor. */
256 expr->expr_type = EXPR_ARRAY;
257 expr->rank = ref->u.ar.as->rank;
260 gcc_assert (expr->expr_type == EXPR_ARRAY);
262 if (ref->u.ar.type == AR_ELEMENT)
263 get_array_index (&ref->u.ar, &offset);
265 mpz_set (offset, index);
267 /* Find the same element in the existing constructor. */
268 con = expr->value.constructor;
269 con = find_con_by_offset (offset, con);
273 /* Create a new constructor. */
274 con = gfc_get_constructor ();
275 mpz_set (con->n.offset, offset);
276 gfc_insert_constructor (expr, con);
283 /* Setup the expression to hold the constructor. */
284 expr->expr_type = EXPR_STRUCTURE;
285 expr->ts.type = BT_DERIVED;
286 expr->ts.derived = ref->u.c.sym;
289 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
290 last_ts = &ref->u.c.component->ts;
292 /* Find the same element in the existing constructor. */
293 con = expr->value.constructor;
294 con = find_con_by_component (ref->u.c.component, con);
298 /* Create a new constructor. */
299 con = gfc_get_constructor ();
300 con->n.component = ref->u.c.component;
301 con->next = expr->value.constructor;
302 expr->value.constructor = con;
312 /* Point the container at the new expression. */
313 if (last_con == NULL)
314 symbol->value = expr;
316 last_con->expr = expr;
322 if (ref || last_ts->type == BT_CHARACTER)
323 expr = create_character_intializer (init, last_ts, ref, rvalue);
326 /* Overwriting an existing initializer is non-standard but usually only
327 provokes a warning from other compilers. */
330 /* Order in which the expressions arrive here depends on whether they
331 are from data statements or F95 style declarations. Therefore,
332 check which is the most recent. */
333 #ifdef USE_MAPPED_LOCATION
334 expr = (LOCATION_LINE (init->where.lb->location)
335 > LOCATION_LINE (rvalue->where.lb->location))
338 expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
341 gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
342 "of '%s' at %L", symbol->name, &expr->where);
345 expr = gfc_copy_expr (rvalue);
346 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
347 gfc_convert_type (expr, &lvalue->ts, 0);
350 if (last_con == NULL)
351 symbol->value = expr;
353 last_con->expr = expr;
356 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
357 value in RVALUE. For the nonce, LVALUE must refer to a full array, not
361 gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
362 mpz_t index, mpz_t repeat)
365 gfc_expr *init, *expr;
366 gfc_constructor *con, *last_con;
368 gfc_typespec *last_ts;
371 symbol = lvalue->symtree->n.sym;
372 init = symbol->value;
373 last_ts = &symbol->ts;
375 mpz_init_set_si (offset, 0);
377 /* Find/create the parent expressions for subobject references. */
378 for (ref = lvalue->ref; ref; ref = ref->next)
380 /* Use the existing initializer expression if it exists.
381 Otherwise create a new one. */
383 expr = gfc_get_expr ();
387 /* Find or create this element. */
393 /* The element typespec will be the same as the array
396 /* Setup the expression to hold the constructor. */
397 expr->expr_type = EXPR_ARRAY;
398 expr->rank = ref->u.ar.as->rank;
401 gcc_assert (expr->expr_type == EXPR_ARRAY);
403 if (ref->u.ar.type == AR_ELEMENT)
405 get_array_index (&ref->u.ar, &offset);
407 /* This had better not be the bottom of the reference.
408 We can still get to a full array via a component. */
409 gcc_assert (ref->next != NULL);
413 mpz_set (offset, index);
415 /* We're at a full array or an array section. This means
416 that we've better have found a full array, and that we're
417 at the bottom of the reference. */
418 gcc_assert (ref->u.ar.type == AR_FULL);
419 gcc_assert (ref->next == NULL);
422 /* Find the same element in the existing constructor. */
423 con = expr->value.constructor;
424 con = find_con_by_offset (offset, con);
426 /* Create a new constructor. */
429 con = gfc_get_constructor ();
430 mpz_set (con->n.offset, offset);
431 if (ref->next == NULL)
432 mpz_set (con->repeat, repeat);
433 gfc_insert_constructor (expr, con);
436 gcc_assert (ref->next != NULL);
442 /* Setup the expression to hold the constructor. */
443 expr->expr_type = EXPR_STRUCTURE;
444 expr->ts.type = BT_DERIVED;
445 expr->ts.derived = ref->u.c.sym;
448 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
449 last_ts = &ref->u.c.component->ts;
451 /* Find the same element in the existing constructor. */
452 con = expr->value.constructor;
453 con = find_con_by_component (ref->u.c.component, con);
457 /* Create a new constructor. */
458 con = gfc_get_constructor ();
459 con->n.component = ref->u.c.component;
460 con->next = expr->value.constructor;
461 expr->value.constructor = con;
464 /* Since we're only intending to initialize arrays here,
465 there better be an inner reference. */
466 gcc_assert (ref->next != NULL);
476 /* Point the container at the new expression. */
477 if (last_con == NULL)
478 symbol->value = expr;
480 last_con->expr = expr;
486 if (last_ts->type == BT_CHARACTER)
487 expr = create_character_intializer (init, last_ts, NULL, rvalue);
490 /* We should never be overwriting an existing initializer. */
493 expr = gfc_copy_expr (rvalue);
494 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
495 gfc_convert_type (expr, &lvalue->ts, 0);
498 if (last_con == NULL)
499 symbol->value = expr;
501 last_con->expr = expr;
504 /* Modify the index of array section and re-calculate the array offset. */
507 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
516 for (i = 0; i < ar->dimen; i++)
518 if (ar->dimen_type[i] != DIMEN_RANGE)
523 mpz_add (section_index[i], section_index[i],
524 ar->stride[i]->value.integer);
525 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
532 mpz_add_ui (section_index[i], section_index[i], 1);
537 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
539 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
541 if ((cmp > 0 && forwards)
542 || (cmp < 0 && ! forwards))
544 /* Reset index to start, then loop to advance the next index. */
546 mpz_set (section_index[i], ar->start[i]->value.integer);
548 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
554 mpz_set_si (*offset_ret, 0);
555 mpz_init_set_si (delta, 1);
557 for (i = 0; i < ar->dimen; i++)
559 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
560 mpz_mul (tmp, tmp, delta);
561 mpz_add (*offset_ret, tmp, *offset_ret);
563 mpz_sub (tmp, ar->as->upper[i]->value.integer,
564 ar->as->lower[i]->value.integer);
565 mpz_add_ui (tmp, tmp, 1);
566 mpz_mul (delta, tmp, delta);
573 /* Rearrange a structure constructor so the elements are in the specified
574 order. Also insert NULL entries if necessary. */
577 formalize_structure_cons (gfc_expr * expr)
579 gfc_constructor *head;
580 gfc_constructor *tail;
581 gfc_constructor *cur;
582 gfc_constructor *last;
584 gfc_component *order;
586 c = expr->value.constructor;
588 /* Constructor is already formalized. */
589 if (c->n.component == NULL)
593 for (order = expr->ts.derived->components; order; order = order->next)
595 /* Find the next component. */
598 while (cur != NULL && cur->n.component != order)
606 /* Create a new one. */
607 cur = gfc_get_constructor ();
611 /* Remove it from the chain. */
615 last->next = cur->next;
618 formalize_init_expr (cur->expr);
621 /* Add it to the new constructor. */
630 gcc_assert (c == NULL);
631 expr->value.constructor = head;
635 /* Make sure an initialization expression is in normalized form. Ie. all
636 elements of the constructors are in the correct order. */
639 formalize_init_expr (gfc_expr * expr)
647 type = expr->expr_type;
651 c = expr->value.constructor;
654 formalize_init_expr (c->expr);
660 formalize_structure_cons (expr);
669 /* Resolve symbol's initial value after all data statement. */
672 gfc_formalize_init_value (gfc_symbol *sym)
674 formalize_init_expr (sym->value);
678 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
682 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
688 mpz_set_si (*offset, 0);
690 mpz_init_set_si (delta, 1);
691 for (i = 0; i < ar->dimen; i++)
693 mpz_init (section_index[i]);
694 switch (ar->dimen_type[i])
700 mpz_sub (tmp, ar->start[i]->value.integer,
701 ar->as->lower[i]->value.integer);
702 mpz_mul (tmp, tmp, delta);
703 mpz_add (*offset, tmp, *offset);
704 mpz_set (section_index[i], ar->start[i]->value.integer);
707 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
711 gfc_internal_error ("TODO: Vector sections in data statements");
717 mpz_sub (tmp, ar->as->upper[i]->value.integer,
718 ar->as->lower[i]->value.integer);
719 mpz_add_ui (tmp, tmp, 1);
720 mpz_mul (delta, tmp, delta);