Fix ChangeLog
[official-gcc.git] / gcc / fortran / data.c
blob6cc7223af2f37422364aba1376c87c5b2df95613
1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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
11 version.
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
16 for more details.
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 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
34 trans-array.c. */
36 #include "config.h"
37 #include "gfortran.h"
38 #include "data.h"
40 static void formalize_init_expr (gfc_expr *);
42 /* Calculate the array element offset. */
44 static void
45 get_array_index (gfc_array_ref *ar, mpz_t *offset)
47 gfc_expr *e;
48 int i;
49 try re;
50 mpz_t delta;
51 mpz_t tmp;
53 mpz_init (tmp);
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);
76 mpz_clear (delta);
77 mpz_clear (tmp);
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)
86 mpz_t tmp;
87 gfc_constructor *ret = NULL;
88 gfc_constructor *con;
89 splay_tree_node sptn;
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);
97 mpz_init (tmp);
99 sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
101 if (sptn)
102 ret = (gfc_constructor*) sptn->value;
103 else
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));
109 if (sptn)
111 con = (gfc_constructor*) sptn->value;
112 if (mpz_cmp_ui (con->repeat, 1) > 0)
114 mpz_init (tmp);
115 mpz_add (tmp, con->n.offset, con->repeat);
116 if (mpz_cmp (offset, tmp) < 0)
117 ret = con;
118 mpz_clear (tmp);
120 else
121 ret = NULL; /* The range did not match. */
123 else
124 ret = NULL; /* No pred, so no match. */
127 return ret;
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)
139 return con;
141 return NULL;
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. */
150 static gfc_expr *
151 create_character_intializer (gfc_expr *init, gfc_typespec *ts,
152 gfc_ref *ref, gfc_expr *rvalue)
154 int len, start, end;
155 gfc_char_t *dest;
157 gfc_extract_int (ts->cl->length, &len);
159 if (init == NULL)
161 /* Create a new initializer. */
162 init = gfc_get_expr ();
163 init->expr_type = EXPR_CONSTANT;
164 init->ts = *ts;
166 dest = gfc_get_wide_string (len + 1);
167 dest[len] = '\0';
168 init->value.character.length = len;
169 init->value.character.string = dest;
170 /* Blank the string if we're only setting a substring. */
171 if (ref != NULL)
172 gfc_wide_memset (dest, ' ', len);
174 else
175 dest = init->value.character.string;
177 if (ref)
179 gfc_expr *start_expr, *end_expr;
181 gcc_assert (ref->type == REF_SUBSTRING);
183 /* Only set a substring of the destination. Fortran substring bounds
184 are one-based [start, end], we want zero based [start, end). */
185 start_expr = gfc_copy_expr (ref->u.ss.start);
186 end_expr = gfc_copy_expr (ref->u.ss.end);
188 if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
189 || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
191 gfc_error ("failure to simplify substring reference in DATA "
192 "statement at %L", &ref->u.ss.start->where);
193 return NULL;
196 gfc_extract_int (start_expr, &start);
197 start--;
198 gfc_extract_int (end_expr, &end);
200 else
202 /* Set the whole string. */
203 start = 0;
204 end = len;
207 /* Copy the initial value. */
208 if (rvalue->ts.type == BT_HOLLERITH)
209 len = rvalue->representation.length;
210 else
211 len = rvalue->value.character.length;
213 if (len > end - start)
215 len = end - start;
216 gfc_warning_now ("initialization string truncated to match variable "
217 "at %L", &rvalue->where);
220 if (rvalue->ts.type == BT_HOLLERITH)
222 int i;
223 for (i = 0; i < len; i++)
224 dest[start+i] = rvalue->representation.string[i];
226 else
227 memcpy (&dest[start], rvalue->value.character.string,
228 len * sizeof (gfc_char_t));
230 /* Pad with spaces. Substrings will already be blanked. */
231 if (len < end - start && ref == NULL)
232 gfc_wide_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
238 = gfc_widechar_to_char (init->value.character.string,
239 init->value.character.length);
242 return init;
246 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
247 LVALUE already has an initialization, we extend this, otherwise we
248 create a new one. */
251 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
253 gfc_ref *ref;
254 gfc_expr *init;
255 gfc_expr *expr;
256 gfc_constructor *con;
257 gfc_constructor *last_con;
258 gfc_constructor *pred;
259 gfc_symbol *symbol;
260 gfc_typespec *last_ts;
261 mpz_t offset;
262 splay_tree spt;
263 splay_tree_node sptn;
265 symbol = lvalue->symtree->n.sym;
266 init = symbol->value;
267 last_ts = &symbol->ts;
268 last_con = NULL;
269 mpz_init_set_si (offset, 0);
271 /* Find/create the parent expressions for subobject references. */
272 for (ref = lvalue->ref; ref; ref = ref->next)
274 /* Break out of the loop if we find a substring. */
275 if (ref->type == REF_SUBSTRING)
277 /* A substring should always be the last subobject reference. */
278 gcc_assert (ref->next == NULL);
279 break;
282 /* Use the existing initializer expression if it exists. Otherwise
283 create a new one. */
284 if (init == NULL)
285 expr = gfc_get_expr ();
286 else
287 expr = init;
289 /* Find or create this element. */
290 switch (ref->type)
292 case REF_ARRAY:
293 if (init && expr->expr_type != EXPR_ARRAY)
295 gfc_error ("'%s' at %L already is initialized at %L",
296 lvalue->symtree->n.sym->name, &lvalue->where,
297 &init->where);
298 return FAILURE;
301 if (init == NULL)
303 /* The element typespec will be the same as the array
304 typespec. */
305 expr->ts = *last_ts;
306 /* Setup the expression to hold the constructor. */
307 expr->expr_type = EXPR_ARRAY;
308 expr->rank = ref->u.ar.as->rank;
311 if (ref->u.ar.type == AR_ELEMENT)
312 get_array_index (&ref->u.ar, &offset);
313 else
314 mpz_set (offset, index);
316 /* Check the bounds. */
317 if (mpz_cmp_si (offset, 0) < 0)
319 gfc_error ("Data element below array lower bound at %L",
320 &lvalue->where);
321 return FAILURE;
323 else
325 mpz_t size;
326 if (spec_size (ref->u.ar.as, &size) == SUCCESS)
328 if (mpz_cmp (offset, size) >= 0)
330 mpz_clear (size);
331 gfc_error ("Data element above array upper bound at %L",
332 &lvalue->where);
333 return FAILURE;
335 mpz_clear (size);
339 /* Splay tree containing offset and gfc_constructor. */
340 spt = expr->con_by_offset;
342 if (spt == NULL)
344 spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
345 expr->con_by_offset = spt;
346 con = NULL;
348 else
349 con = find_con_by_offset (spt, offset);
351 if (con == NULL)
353 splay_tree_key j;
355 /* Create a new constructor. */
356 con = gfc_get_constructor ();
357 mpz_set (con->n.offset, offset);
358 j = (splay_tree_key) mpz_get_si (offset);
359 sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
360 /* Fix up the linked list. */
361 sptn = splay_tree_predecessor (spt, j);
362 if (sptn == NULL)
363 { /* Insert at the head. */
364 con->next = expr->value.constructor;
365 expr->value.constructor = con;
367 else
368 { /* Insert in the chain. */
369 pred = (gfc_constructor*) sptn->value;
370 con->next = pred->next;
371 pred->next = con;
374 break;
376 case REF_COMPONENT:
377 if (init == NULL)
379 /* Setup the expression to hold the constructor. */
380 expr->expr_type = EXPR_STRUCTURE;
381 expr->ts.type = BT_DERIVED;
382 expr->ts.derived = ref->u.c.sym;
384 else
385 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
386 last_ts = &ref->u.c.component->ts;
388 /* Find the same element in the existing constructor. */
389 con = expr->value.constructor;
390 con = find_con_by_component (ref->u.c.component, con);
392 if (con == NULL)
394 /* Create a new constructor. */
395 con = gfc_get_constructor ();
396 con->n.component = ref->u.c.component;
397 con->next = expr->value.constructor;
398 expr->value.constructor = con;
400 break;
402 default:
403 gcc_unreachable ();
406 if (init == NULL)
408 /* Point the container at the new expression. */
409 if (last_con == NULL)
410 symbol->value = expr;
411 else
412 last_con->expr = expr;
414 init = con->expr;
415 last_con = con;
418 if (ref || last_ts->type == BT_CHARACTER)
419 expr = create_character_intializer (init, last_ts, ref, rvalue);
420 else
422 /* Overwriting an existing initializer is non-standard but usually only
423 provokes a warning from other compilers. */
424 if (init != NULL)
426 /* Order in which the expressions arrive here depends on whether
427 they are from data statements or F95 style declarations.
428 Therefore, check which is the most recent. */
429 expr = (LOCATION_LINE (init->where.lb->location)
430 > LOCATION_LINE (rvalue->where.lb->location))
431 ? init : rvalue;
432 gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
433 "of '%s' at %L", symbol->name, &expr->where);
436 expr = gfc_copy_expr (rvalue);
437 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
438 gfc_convert_type (expr, &lvalue->ts, 0);
441 if (last_con == NULL)
442 symbol->value = expr;
443 else
444 last_con->expr = expr;
446 return SUCCESS;
450 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
451 value in RVALUE. For the nonce, LVALUE must refer to a full array, not
452 an array section. */
454 void
455 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
456 mpz_t index, mpz_t repeat)
458 gfc_ref *ref;
459 gfc_expr *init, *expr;
460 gfc_constructor *con, *last_con;
461 gfc_constructor *pred;
462 gfc_symbol *symbol;
463 gfc_typespec *last_ts;
464 mpz_t offset;
465 splay_tree spt;
466 splay_tree_node sptn;
468 symbol = lvalue->symtree->n.sym;
469 init = symbol->value;
470 last_ts = &symbol->ts;
471 last_con = NULL;
472 mpz_init_set_si (offset, 0);
474 /* Find/create the parent expressions for subobject references. */
475 for (ref = lvalue->ref; ref; ref = ref->next)
477 /* Use the existing initializer expression if it exists.
478 Otherwise create a new one. */
479 if (init == NULL)
480 expr = gfc_get_expr ();
481 else
482 expr = init;
484 /* Find or create this element. */
485 switch (ref->type)
487 case REF_ARRAY:
488 if (init == NULL)
490 /* The element typespec will be the same as the array
491 typespec. */
492 expr->ts = *last_ts;
493 /* Setup the expression to hold the constructor. */
494 expr->expr_type = EXPR_ARRAY;
495 expr->rank = ref->u.ar.as->rank;
497 else
498 gcc_assert (expr->expr_type == EXPR_ARRAY);
500 if (ref->u.ar.type == AR_ELEMENT)
502 get_array_index (&ref->u.ar, &offset);
504 /* This had better not be the bottom of the reference.
505 We can still get to a full array via a component. */
506 gcc_assert (ref->next != NULL);
508 else
510 mpz_set (offset, index);
512 /* We're at a full array or an array section. This means
513 that we've better have found a full array, and that we're
514 at the bottom of the reference. */
515 gcc_assert (ref->u.ar.type == AR_FULL);
516 gcc_assert (ref->next == NULL);
519 /* Find the same element in the existing constructor. */
521 /* Splay tree containing offset and gfc_constructor. */
522 spt = expr->con_by_offset;
524 if (spt == NULL)
526 spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
527 expr->con_by_offset = spt;
528 con = NULL;
530 else
531 con = find_con_by_offset (spt, offset);
533 if (con == NULL)
535 splay_tree_key j;
536 /* Create a new constructor. */
537 con = gfc_get_constructor ();
538 mpz_set (con->n.offset, offset);
539 j = (splay_tree_key) mpz_get_si (offset);
541 if (ref->next == NULL)
542 mpz_set (con->repeat, repeat);
543 sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
544 /* Fix up the linked list. */
545 sptn = splay_tree_predecessor (spt, j);
546 if (sptn == NULL)
547 { /* Insert at the head. */
548 con->next = expr->value.constructor;
549 expr->value.constructor = con;
551 else
552 { /* Insert in the chain. */
553 pred = (gfc_constructor*) sptn->value;
554 con->next = pred->next;
555 pred->next = con;
558 else
559 gcc_assert (ref->next != NULL);
560 break;
562 case REF_COMPONENT:
563 if (init == NULL)
565 /* Setup the expression to hold the constructor. */
566 expr->expr_type = EXPR_STRUCTURE;
567 expr->ts.type = BT_DERIVED;
568 expr->ts.derived = ref->u.c.sym;
570 else
571 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
572 last_ts = &ref->u.c.component->ts;
574 /* Find the same element in the existing constructor. */
575 con = expr->value.constructor;
576 con = find_con_by_component (ref->u.c.component, con);
578 if (con == NULL)
580 /* Create a new constructor. */
581 con = gfc_get_constructor ();
582 con->n.component = ref->u.c.component;
583 con->next = expr->value.constructor;
584 expr->value.constructor = con;
587 /* Since we're only intending to initialize arrays here,
588 there better be an inner reference. */
589 gcc_assert (ref->next != NULL);
590 break;
592 case REF_SUBSTRING:
593 default:
594 gcc_unreachable ();
597 if (init == NULL)
599 /* Point the container at the new expression. */
600 if (last_con == NULL)
601 symbol->value = expr;
602 else
603 last_con->expr = expr;
605 init = con->expr;
606 last_con = con;
609 if (last_ts->type == BT_CHARACTER)
610 expr = create_character_intializer (init, last_ts, NULL, rvalue);
611 else
613 /* We should never be overwriting an existing initializer. */
614 gcc_assert (!init);
616 expr = gfc_copy_expr (rvalue);
617 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
618 gfc_convert_type (expr, &lvalue->ts, 0);
621 if (last_con == NULL)
622 symbol->value = expr;
623 else
624 last_con->expr = expr;
627 /* Modify the index of array section and re-calculate the array offset. */
629 void
630 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
631 mpz_t *offset_ret)
633 int i;
634 mpz_t delta;
635 mpz_t tmp;
636 bool forwards;
637 int cmp;
639 for (i = 0; i < ar->dimen; i++)
641 if (ar->dimen_type[i] != DIMEN_RANGE)
642 continue;
644 if (ar->stride[i])
646 mpz_add (section_index[i], section_index[i],
647 ar->stride[i]->value.integer);
648 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
649 forwards = true;
650 else
651 forwards = false;
653 else
655 mpz_add_ui (section_index[i], section_index[i], 1);
656 forwards = true;
659 if (ar->end[i])
660 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
661 else
662 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
664 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
666 /* Reset index to start, then loop to advance the next index. */
667 if (ar->start[i])
668 mpz_set (section_index[i], ar->start[i]->value.integer);
669 else
670 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
672 else
673 break;
676 mpz_set_si (*offset_ret, 0);
677 mpz_init_set_si (delta, 1);
678 mpz_init (tmp);
679 for (i = 0; i < ar->dimen; i++)
681 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
682 mpz_mul (tmp, tmp, delta);
683 mpz_add (*offset_ret, tmp, *offset_ret);
685 mpz_sub (tmp, ar->as->upper[i]->value.integer,
686 ar->as->lower[i]->value.integer);
687 mpz_add_ui (tmp, tmp, 1);
688 mpz_mul (delta, tmp, delta);
690 mpz_clear (tmp);
691 mpz_clear (delta);
695 /* Rearrange a structure constructor so the elements are in the specified
696 order. Also insert NULL entries if necessary. */
698 static void
699 formalize_structure_cons (gfc_expr *expr)
701 gfc_constructor *head;
702 gfc_constructor *tail;
703 gfc_constructor *cur;
704 gfc_constructor *last;
705 gfc_constructor *c;
706 gfc_component *order;
708 c = expr->value.constructor;
710 /* Constructor is already formalized. */
711 if (!c || c->n.component == NULL)
712 return;
714 head = tail = NULL;
715 for (order = expr->ts.derived->components; order; order = order->next)
717 /* Find the next component. */
718 last = NULL;
719 cur = c;
720 while (cur != NULL && cur->n.component != order)
722 last = cur;
723 cur = cur->next;
726 if (cur == NULL)
728 /* Create a new one. */
729 cur = gfc_get_constructor ();
731 else
733 /* Remove it from the chain. */
734 if (last == NULL)
735 c = cur->next;
736 else
737 last->next = cur->next;
738 cur->next = NULL;
740 formalize_init_expr (cur->expr);
743 /* Add it to the new constructor. */
744 if (head == NULL)
745 head = tail = cur;
746 else
748 tail->next = cur;
749 tail = tail->next;
752 gcc_assert (c == NULL);
753 expr->value.constructor = head;
757 /* Make sure an initialization expression is in normalized form. Ie. all
758 elements of the constructors are in the correct order. */
760 static void
761 formalize_init_expr (gfc_expr *expr)
763 expr_t type;
764 gfc_constructor *c;
766 if (expr == NULL)
767 return;
769 type = expr->expr_type;
770 switch (type)
772 case EXPR_ARRAY:
773 c = expr->value.constructor;
774 while (c)
776 formalize_init_expr (c->expr);
777 c = c->next;
779 break;
781 case EXPR_STRUCTURE:
782 formalize_structure_cons (expr);
783 break;
785 default:
786 break;
791 /* Resolve symbol's initial value after all data statement. */
793 void
794 gfc_formalize_init_value (gfc_symbol *sym)
796 formalize_init_expr (sym->value);
800 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
801 offset. */
803 void
804 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
806 int i;
807 mpz_t delta;
808 mpz_t tmp;
810 mpz_set_si (*offset, 0);
811 mpz_init (tmp);
812 mpz_init_set_si (delta, 1);
813 for (i = 0; i < ar->dimen; i++)
815 mpz_init (section_index[i]);
816 switch (ar->dimen_type[i])
818 case DIMEN_ELEMENT:
819 case DIMEN_RANGE:
820 if (ar->start[i])
822 mpz_sub (tmp, ar->start[i]->value.integer,
823 ar->as->lower[i]->value.integer);
824 mpz_mul (tmp, tmp, delta);
825 mpz_add (*offset, tmp, *offset);
826 mpz_set (section_index[i], ar->start[i]->value.integer);
828 else
829 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
830 break;
832 case DIMEN_VECTOR:
833 gfc_internal_error ("TODO: Vector sections in data statements");
835 default:
836 gcc_unreachable ();
839 mpz_sub (tmp, ar->as->upper[i]->value.integer,
840 ar->as->lower[i]->value.integer);
841 mpz_add_ui (tmp, tmp, 1);
842 mpz_mul (delta, tmp, delta);
845 mpz_clear (tmp);
846 mpz_clear (delta);