1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
24 /* Notes for DATA statement implementation:
26 We first assign initial value to each symbol by gfc_assign_data_value
27 during resolveing DATA statement. Refer to check_data_variable and
28 traverse_data_list in resolve.c.
30 The complexity exists in the handling of array section, implied do
31 and array of struct appeared in DATA statement.
33 We call gfc_conv_structure, gfc_con_array_array_initializer,
34 etc., to convert the initial value. Refer to trans-expr.c and
40 static void formalize_init_expr (gfc_expr *);
42 /* Calculate the array element offset. */
45 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 re = 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);
81 /* Find if there is a constructor which offset is equal to OFFSET. */
83 static gfc_constructor *
84 find_con_by_offset (splay_tree spt, mpz_t offset)
87 gfc_constructor *ret = NULL;
91 /* The complexity is due to needing quick access to the linked list of
92 constructors. Both a linked list and a splay tree are used, and both
93 are kept up to date if they are array elements (which is the only time
94 that a specific constructor has to be found). */
96 gcc_assert (spt != NULL);
99 sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
102 ret = (gfc_constructor*) sptn->value;
105 /* Need to check and see if we match a range, so we will pull
106 the next lowest index and see if the range matches. */
107 sptn = splay_tree_predecessor (spt,
108 (splay_tree_key) mpz_get_si (offset));
111 con = (gfc_constructor*) sptn->value;
112 if (mpz_cmp_ui (con->repeat, 1) > 0)
115 mpz_add (tmp, con->n.offset, con->repeat);
116 if (mpz_cmp (offset, tmp) < 0)
121 ret = NULL; /* The range did not match. */
124 ret = NULL; /* No pred, so no match. */
131 /* Find if there is a constructor which component is equal to COM. */
133 static gfc_constructor *
134 find_con_by_component (gfc_component *com, gfc_constructor *con)
136 for (; con; con = con->next)
138 if (com == con->n.component)
145 /* Create a character type initialization expression from RVALUE.
146 TS [and REF] describe [the substring of] the variable being initialized.
147 INIT is thh existing initializer, not NULL. Initialization is performed
148 according to normal assignment rules. */
151 create_character_intializer (gfc_expr *init, gfc_typespec *ts,
152 gfc_ref *ref, gfc_expr *rvalue)
157 char *dest, *rvalue_string;
159 gfc_extract_int (ts->cl->length, &len);
163 /* Create a new initializer. */
164 init = gfc_get_expr ();
165 init->expr_type = EXPR_CONSTANT;
168 dest = gfc_getmem (len + 1);
170 init->value.character.length = len;
171 init->value.character.string = dest;
172 /* Blank the string if we're only setting a substring. */
174 memset (dest, ' ', len);
177 dest = init->value.character.string;
181 gfc_expr *start_expr, *end_expr;
183 gcc_assert (ref->type == REF_SUBSTRING);
185 /* Only set a substring of the destination. Fortran substring bounds
186 are one-based [start, end], we want zero based [start, end). */
187 start_expr = gfc_copy_expr (ref->u.ss.start);
188 end_expr = gfc_copy_expr (ref->u.ss.end);
190 if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
191 || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
193 gfc_error ("failure to simplify substring reference in DATA "
194 "statement at %L", &ref->u.ss.start->where);
198 gfc_extract_int (start_expr, &start);
200 gfc_extract_int (end_expr, &end);
204 /* Set the whole string. */
209 /* Copy the initial value. */
210 if (rvalue->ts.type == BT_HOLLERITH)
212 len = rvalue->representation.length;
213 rvalue_string = rvalue->representation.string;
217 len = rvalue->value.character.length;
218 rvalue_string = rvalue->value.character.string;
221 if (len > end - start)
224 gfc_warning_now ("initialization string truncated to match variable "
225 "at %L", &rvalue->where);
228 memcpy (&dest[start], rvalue_string, len);
230 /* Pad with spaces. Substrings will already be blanked. */
231 if (len < end - start && ref == NULL)
232 memset (&dest[start + len], ' ', end - (start + len));
234 if (rvalue->ts.type == BT_HOLLERITH)
236 init->representation.length = init->value.character.length;
237 init->representation.string = init->value.character.string;
244 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
245 LVALUE already has an initialization, we extend this, otherwise we
249 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
254 gfc_constructor *con;
255 gfc_constructor *last_con;
256 gfc_constructor *pred;
258 gfc_typespec *last_ts;
261 splay_tree_node sptn;
263 symbol = lvalue->symtree->n.sym;
264 init = symbol->value;
265 last_ts = &symbol->ts;
267 mpz_init_set_si (offset, 0);
269 /* Find/create the parent expressions for subobject references. */
270 for (ref = lvalue->ref; ref; ref = ref->next)
272 /* Break out of the loop if we find a substring. */
273 if (ref->type == REF_SUBSTRING)
275 /* A substring should always be the last subobject reference. */
276 gcc_assert (ref->next == NULL);
280 /* Use the existing initializer expression if it exists. Otherwise
283 expr = gfc_get_expr ();
287 /* Find or create this element. */
291 if (init && expr->expr_type != EXPR_ARRAY)
293 gfc_error ("'%s' at %L already is initialized at %L",
294 lvalue->symtree->n.sym->name, &lvalue->where,
296 gfc_free_expr (init);
302 /* The element typespec will be the same as the array
305 /* Setup the expression to hold the constructor. */
306 expr->expr_type = EXPR_ARRAY;
307 expr->rank = ref->u.ar.as->rank;
310 if (ref->u.ar.type == AR_ELEMENT)
311 get_array_index (&ref->u.ar, &offset);
313 mpz_set (offset, index);
315 /* Splay tree containing offset and gfc_constructor. */
316 spt = expr->con_by_offset;
320 spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
321 expr->con_by_offset = spt;
325 con = find_con_by_offset (spt, offset);
331 /* Create a new constructor. */
332 con = gfc_get_constructor ();
333 mpz_set (con->n.offset, offset);
334 j = (splay_tree_key) mpz_get_si (offset);
335 sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
336 /* Fix up the linked list. */
337 sptn = splay_tree_predecessor (spt, j);
339 { /* Insert at the head. */
340 con->next = expr->value.constructor;
341 expr->value.constructor = con;
344 { /* Insert in the chain. */
345 pred = (gfc_constructor*) sptn->value;
346 con->next = pred->next;
355 /* Setup the expression to hold the constructor. */
356 expr->expr_type = EXPR_STRUCTURE;
357 expr->ts.type = BT_DERIVED;
358 expr->ts.derived = ref->u.c.sym;
361 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
362 last_ts = &ref->u.c.component->ts;
364 /* Find the same element in the existing constructor. */
365 con = expr->value.constructor;
366 con = find_con_by_component (ref->u.c.component, con);
370 /* Create a new constructor. */
371 con = gfc_get_constructor ();
372 con->n.component = ref->u.c.component;
373 con->next = expr->value.constructor;
374 expr->value.constructor = con;
384 /* Point the container at the new expression. */
385 if (last_con == NULL)
386 symbol->value = expr;
388 last_con->expr = expr;
394 if (ref || last_ts->type == BT_CHARACTER)
395 expr = create_character_intializer (init, last_ts, ref, rvalue);
398 /* Overwriting an existing initializer is non-standard but usually only
399 provokes a warning from other compilers. */
402 /* Order in which the expressions arrive here depends on whether
403 they are from data statements or F95 style declarations.
404 Therefore, check which is the most recent. */
405 #ifdef USE_MAPPED_LOCATION
406 expr = (LOCATION_LINE (init->where.lb->location)
407 > LOCATION_LINE (rvalue->where.lb->location))
410 expr = (init->where.lb->linenum > rvalue->where.lb->linenum)
413 gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
414 "of '%s' at %L", symbol->name, &expr->where);
417 expr = gfc_copy_expr (rvalue);
418 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
419 gfc_convert_type (expr, &lvalue->ts, 0);
422 if (last_con == NULL)
423 symbol->value = expr;
425 last_con->expr = expr;
429 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
430 value in RVALUE. For the nonce, LVALUE must refer to a full array, not
434 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
435 mpz_t index, mpz_t repeat)
438 gfc_expr *init, *expr;
439 gfc_constructor *con, *last_con;
440 gfc_constructor *pred;
442 gfc_typespec *last_ts;
445 splay_tree_node sptn;
447 symbol = lvalue->symtree->n.sym;
448 init = symbol->value;
449 last_ts = &symbol->ts;
451 mpz_init_set_si (offset, 0);
453 /* Find/create the parent expressions for subobject references. */
454 for (ref = lvalue->ref; ref; ref = ref->next)
456 /* Use the existing initializer expression if it exists.
457 Otherwise create a new one. */
459 expr = gfc_get_expr ();
463 /* Find or create this element. */
469 /* The element typespec will be the same as the array
472 /* Setup the expression to hold the constructor. */
473 expr->expr_type = EXPR_ARRAY;
474 expr->rank = ref->u.ar.as->rank;
477 gcc_assert (expr->expr_type == EXPR_ARRAY);
479 if (ref->u.ar.type == AR_ELEMENT)
481 get_array_index (&ref->u.ar, &offset);
483 /* This had better not be the bottom of the reference.
484 We can still get to a full array via a component. */
485 gcc_assert (ref->next != NULL);
489 mpz_set (offset, index);
491 /* We're at a full array or an array section. This means
492 that we've better have found a full array, and that we're
493 at the bottom of the reference. */
494 gcc_assert (ref->u.ar.type == AR_FULL);
495 gcc_assert (ref->next == NULL);
498 /* Find the same element in the existing constructor. */
500 /* Splay tree containing offset and gfc_constructor. */
501 spt = expr->con_by_offset;
505 spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
506 expr->con_by_offset = spt;
510 con = find_con_by_offset (spt, offset);
515 /* Create a new constructor. */
516 con = gfc_get_constructor ();
517 mpz_set (con->n.offset, offset);
518 j = (splay_tree_key) mpz_get_si (offset);
520 if (ref->next == NULL)
521 mpz_set (con->repeat, repeat);
522 sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
523 /* Fix up the linked list. */
524 sptn = splay_tree_predecessor (spt, j);
526 { /* Insert at the head. */
527 con->next = expr->value.constructor;
528 expr->value.constructor = con;
531 { /* Insert in the chain. */
532 pred = (gfc_constructor*) sptn->value;
533 con->next = pred->next;
538 gcc_assert (ref->next != NULL);
544 /* Setup the expression to hold the constructor. */
545 expr->expr_type = EXPR_STRUCTURE;
546 expr->ts.type = BT_DERIVED;
547 expr->ts.derived = ref->u.c.sym;
550 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
551 last_ts = &ref->u.c.component->ts;
553 /* Find the same element in the existing constructor. */
554 con = expr->value.constructor;
555 con = find_con_by_component (ref->u.c.component, con);
559 /* Create a new constructor. */
560 con = gfc_get_constructor ();
561 con->n.component = ref->u.c.component;
562 con->next = expr->value.constructor;
563 expr->value.constructor = con;
566 /* Since we're only intending to initialize arrays here,
567 there better be an inner reference. */
568 gcc_assert (ref->next != NULL);
578 /* Point the container at the new expression. */
579 if (last_con == NULL)
580 symbol->value = expr;
582 last_con->expr = expr;
588 if (last_ts->type == BT_CHARACTER)
589 expr = create_character_intializer (init, last_ts, NULL, rvalue);
592 /* We should never be overwriting an existing initializer. */
595 expr = gfc_copy_expr (rvalue);
596 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
597 gfc_convert_type (expr, &lvalue->ts, 0);
600 if (last_con == NULL)
601 symbol->value = expr;
603 last_con->expr = expr;
606 /* Modify the index of array section and re-calculate the array offset. */
609 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
618 for (i = 0; i < ar->dimen; i++)
620 if (ar->dimen_type[i] != DIMEN_RANGE)
625 mpz_add (section_index[i], section_index[i],
626 ar->stride[i]->value.integer);
627 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
634 mpz_add_ui (section_index[i], section_index[i], 1);
639 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
641 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
643 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
645 /* Reset index to start, then loop to advance the next index. */
647 mpz_set (section_index[i], ar->start[i]->value.integer);
649 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
655 mpz_set_si (*offset_ret, 0);
656 mpz_init_set_si (delta, 1);
658 for (i = 0; i < ar->dimen; i++)
660 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
661 mpz_mul (tmp, tmp, delta);
662 mpz_add (*offset_ret, tmp, *offset_ret);
664 mpz_sub (tmp, ar->as->upper[i]->value.integer,
665 ar->as->lower[i]->value.integer);
666 mpz_add_ui (tmp, tmp, 1);
667 mpz_mul (delta, tmp, delta);
674 /* Rearrange a structure constructor so the elements are in the specified
675 order. Also insert NULL entries if necessary. */
678 formalize_structure_cons (gfc_expr *expr)
680 gfc_constructor *head;
681 gfc_constructor *tail;
682 gfc_constructor *cur;
683 gfc_constructor *last;
685 gfc_component *order;
687 c = expr->value.constructor;
689 /* Constructor is already formalized. */
690 if (c->n.component == NULL)
694 for (order = expr->ts.derived->components; order; order = order->next)
696 /* Find the next component. */
699 while (cur != NULL && cur->n.component != order)
707 /* Create a new one. */
708 cur = gfc_get_constructor ();
712 /* Remove it from the chain. */
716 last->next = cur->next;
719 formalize_init_expr (cur->expr);
722 /* Add it to the new constructor. */
731 gcc_assert (c == NULL);
732 expr->value.constructor = head;
736 /* Make sure an initialization expression is in normalized form. Ie. all
737 elements of the constructors are in the correct order. */
740 formalize_init_expr (gfc_expr *expr)
748 type = expr->expr_type;
752 c = expr->value.constructor;
755 formalize_init_expr (c->expr);
761 formalize_structure_cons (expr);
770 /* Resolve symbol's initial value after all data statement. */
773 gfc_formalize_init_value (gfc_symbol *sym)
775 formalize_init_expr (sym->value);
779 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
783 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
789 mpz_set_si (*offset, 0);
791 mpz_init_set_si (delta, 1);
792 for (i = 0; i < ar->dimen; i++)
794 mpz_init (section_index[i]);
795 switch (ar->dimen_type[i])
801 mpz_sub (tmp, ar->start[i]->value.integer,
802 ar->as->lower[i]->value.integer);
803 mpz_mul (tmp, tmp, delta);
804 mpz_add (*offset, tmp, *offset);
805 mpz_set (section_index[i], ar->start[i]->value.integer);
808 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
812 gfc_internal_error ("TODO: Vector sections in data statements");
818 mpz_sub (tmp, ar->as->upper[i]->value.integer,
819 ar->as->lower[i]->value.integer);
820 mpz_add_ui (tmp, tmp, 1);
821 mpz_mul (delta, tmp, delta);