Reverting merge from trunk
[official-gcc.git] / gcc / fortran / data.c
bloba1c89fa1f0607b14573c6e7e85e2cbb6722b61ef
1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2013 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 3, or (at your option) any later
10 version.
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
15 for more details.
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Notes for DATA statement implementation:
24 We first assign initial value to each symbol by gfc_assign_data_value
25 during resolving DATA statement. Refer to check_data_variable and
26 traverse_data_list in resolve.c.
28 The complexity exists in the handling of array section, implied do
29 and array of struct appeared in DATA statement.
31 We call gfc_conv_structure, gfc_con_array_array_initializer,
32 etc., to convert the initial value. Refer to trans-expr.c and
33 trans-array.c. */
35 #include "config.h"
36 #include "system.h"
37 #include "coretypes.h"
38 #include "gfortran.h"
39 #include "data.h"
40 #include "constructor.h"
42 static void formalize_init_expr (gfc_expr *);
44 /* Calculate the array element offset. */
46 static void
47 get_array_index (gfc_array_ref *ar, mpz_t *offset)
49 gfc_expr *e;
50 int i;
51 mpz_t delta;
52 mpz_t tmp;
54 mpz_init (tmp);
55 mpz_set_si (*offset, 0);
56 mpz_init_set_si (delta, 1);
57 for (i = 0; i < ar->dimen; i++)
59 e = gfc_copy_expr (ar->start[i]);
60 gfc_simplify_expr (e, 1);
62 if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
63 || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
64 || (gfc_is_constant_expr (e) == 0))
65 gfc_error ("non-constant array in DATA statement %L", &ar->where);
67 mpz_set (tmp, e->value.integer);
68 gfc_free_expr (e);
69 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
70 mpz_mul (tmp, tmp, delta);
71 mpz_add (*offset, tmp, *offset);
73 mpz_sub (tmp, ar->as->upper[i]->value.integer,
74 ar->as->lower[i]->value.integer);
75 mpz_add_ui (tmp, tmp, 1);
76 mpz_mul (delta, tmp, delta);
78 mpz_clear (delta);
79 mpz_clear (tmp);
82 /* Find if there is a constructor which component is equal to COM.
83 TODO: remove this, use symbol.c(gfc_find_component) instead. */
85 static gfc_constructor *
86 find_con_by_component (gfc_component *com, gfc_constructor_base base)
88 gfc_constructor *c;
90 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
91 if (com == c->n.component)
92 return c;
94 return NULL;
98 /* Create a character type initialization expression from RVALUE.
99 TS [and REF] describe [the substring of] the variable being initialized.
100 INIT is the existing initializer, not NULL. Initialization is performed
101 according to normal assignment rules. */
103 static gfc_expr *
104 create_character_initializer (gfc_expr *init, gfc_typespec *ts,
105 gfc_ref *ref, gfc_expr *rvalue)
107 int len, start, end;
108 gfc_char_t *dest;
109 bool alloced_init = false;
111 gfc_extract_int (ts->u.cl->length, &len);
113 if (init == NULL)
115 /* Create a new initializer. */
116 init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
117 init->ts = *ts;
118 alloced_init = true;
121 dest = init->value.character.string;
123 if (ref)
125 gfc_expr *start_expr, *end_expr;
127 gcc_assert (ref->type == REF_SUBSTRING);
129 /* Only set a substring of the destination. Fortran substring bounds
130 are one-based [start, end], we want zero based [start, end). */
131 start_expr = gfc_copy_expr (ref->u.ss.start);
132 end_expr = gfc_copy_expr (ref->u.ss.end);
134 if ((!gfc_simplify_expr(start_expr, 1))
135 || !(gfc_simplify_expr(end_expr, 1)))
137 gfc_error ("failure to simplify substring reference in DATA "
138 "statement at %L", &ref->u.ss.start->where);
139 gfc_free_expr (start_expr);
140 gfc_free_expr (end_expr);
141 if (alloced_init)
142 gfc_free_expr (init);
143 return NULL;
146 gfc_extract_int (start_expr, &start);
147 gfc_free_expr (start_expr);
148 start--;
149 gfc_extract_int (end_expr, &end);
150 gfc_free_expr (end_expr);
152 else
154 /* Set the whole string. */
155 start = 0;
156 end = len;
159 /* Copy the initial value. */
160 if (rvalue->ts.type == BT_HOLLERITH)
161 len = rvalue->representation.length - rvalue->ts.u.pad;
162 else
163 len = rvalue->value.character.length;
165 if (len > end - start)
167 gfc_warning_now ("Initialization string starting at %L was "
168 "truncated to fit the variable (%d/%d)",
169 &rvalue->where, end - start, len);
170 len = end - start;
173 if (rvalue->ts.type == BT_HOLLERITH)
175 int i;
176 for (i = 0; i < len; i++)
177 dest[start+i] = rvalue->representation.string[i];
179 else
180 memcpy (&dest[start], rvalue->value.character.string,
181 len * sizeof (gfc_char_t));
183 /* Pad with spaces. Substrings will already be blanked. */
184 if (len < end - start && ref == NULL)
185 gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
187 if (rvalue->ts.type == BT_HOLLERITH)
189 init->representation.length = init->value.character.length;
190 init->representation.string
191 = gfc_widechar_to_char (init->value.character.string,
192 init->value.character.length);
195 return init;
199 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
200 LVALUE already has an initialization, we extend this, otherwise we
201 create a new one. If REPEAT is non-NULL, initialize *REPEAT
202 consecutive values in LVALUE the same value in RVALUE. In that case,
203 LVALUE must refer to a full array, not an array section. */
205 bool
206 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
207 mpz_t *repeat)
209 gfc_ref *ref;
210 gfc_expr *init;
211 gfc_expr *expr = NULL;
212 gfc_constructor *con;
213 gfc_constructor *last_con;
214 gfc_symbol *symbol;
215 gfc_typespec *last_ts;
216 mpz_t offset;
218 symbol = lvalue->symtree->n.sym;
219 init = symbol->value;
220 last_ts = &symbol->ts;
221 last_con = NULL;
222 mpz_init_set_si (offset, 0);
224 /* Find/create the parent expressions for subobject references. */
225 for (ref = lvalue->ref; ref; ref = ref->next)
227 /* Break out of the loop if we find a substring. */
228 if (ref->type == REF_SUBSTRING)
230 /* A substring should always be the last subobject reference. */
231 gcc_assert (ref->next == NULL);
232 break;
235 /* Use the existing initializer expression if it exists. Otherwise
236 create a new one. */
237 if (init == NULL)
238 expr = gfc_get_expr ();
239 else
240 expr = init;
242 /* Find or create this element. */
243 switch (ref->type)
245 case REF_ARRAY:
246 if (ref->u.ar.as->rank == 0)
248 gcc_assert (ref->u.ar.as->corank > 0);
249 if (init == NULL)
250 free (expr);
251 continue;
254 if (init && expr->expr_type != EXPR_ARRAY)
256 gfc_error ("'%s' at %L already is initialized at %L",
257 lvalue->symtree->n.sym->name, &lvalue->where,
258 &init->where);
259 goto abort;
262 if (init == NULL)
264 /* The element typespec will be the same as the array
265 typespec. */
266 expr->ts = *last_ts;
267 /* Setup the expression to hold the constructor. */
268 expr->expr_type = EXPR_ARRAY;
269 expr->rank = ref->u.ar.as->rank;
272 if (ref->u.ar.type == AR_ELEMENT)
273 get_array_index (&ref->u.ar, &offset);
274 else
275 mpz_set (offset, index);
277 /* Check the bounds. */
278 if (mpz_cmp_si (offset, 0) < 0)
280 gfc_error ("Data element below array lower bound at %L",
281 &lvalue->where);
282 goto abort;
284 else if (repeat != NULL
285 && ref->u.ar.type != AR_ELEMENT)
287 mpz_t size, end;
288 gcc_assert (ref->u.ar.type == AR_FULL
289 && ref->next == NULL);
290 mpz_init_set (end, offset);
291 mpz_add (end, end, *repeat);
292 if (spec_size (ref->u.ar.as, &size))
294 if (mpz_cmp (end, size) > 0)
296 mpz_clear (size);
297 gfc_error ("Data element above array upper bound at %L",
298 &lvalue->where);
299 goto abort;
301 mpz_clear (size);
304 con = gfc_constructor_lookup (expr->value.constructor,
305 mpz_get_si (offset));
306 if (!con)
308 con = gfc_constructor_lookup_next (expr->value.constructor,
309 mpz_get_si (offset));
310 if (con != NULL && mpz_cmp (con->offset, end) >= 0)
311 con = NULL;
314 /* Overwriting an existing initializer is non-standard but
315 usually only provokes a warning from other compilers. */
316 if (con != NULL && con->expr != NULL)
318 /* Order in which the expressions arrive here depends on
319 whether they are from data statements or F95 style
320 declarations. Therefore, check which is the most
321 recent. */
322 gfc_expr *exprd;
323 exprd = (LOCATION_LINE (con->expr->where.lb->location)
324 > LOCATION_LINE (rvalue->where.lb->location))
325 ? con->expr : rvalue;
326 if (gfc_notify_std (GFC_STD_GNU,
327 "re-initialization of '%s' at %L",
328 symbol->name, &exprd->where) == false)
329 return false;
332 while (con != NULL)
334 gfc_constructor *next_con = gfc_constructor_next (con);
336 if (mpz_cmp (con->offset, end) >= 0)
337 break;
338 if (mpz_cmp (con->offset, offset) < 0)
340 gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
341 mpz_sub (con->repeat, offset, con->offset);
343 else if (mpz_cmp_si (con->repeat, 1) > 0
344 && mpz_get_si (con->offset)
345 + mpz_get_si (con->repeat) > mpz_get_si (end))
347 int endi;
348 splay_tree_node node
349 = splay_tree_lookup (con->base,
350 mpz_get_si (con->offset));
351 gcc_assert (node
352 && con == (gfc_constructor *) node->value
353 && node->key == (splay_tree_key)
354 mpz_get_si (con->offset));
355 endi = mpz_get_si (con->offset)
356 + mpz_get_si (con->repeat);
357 if (endi > mpz_get_si (end) + 1)
358 mpz_set_si (con->repeat, endi - mpz_get_si (end));
359 else
360 mpz_set_si (con->repeat, 1);
361 mpz_set (con->offset, end);
362 node->key = (splay_tree_key) mpz_get_si (end);
363 break;
365 else
366 gfc_constructor_remove (con);
367 con = next_con;
370 con = gfc_constructor_insert_expr (&expr->value.constructor,
371 NULL, &rvalue->where,
372 mpz_get_si (offset));
373 mpz_set (con->repeat, *repeat);
374 repeat = NULL;
375 mpz_clear (end);
376 break;
378 else
380 mpz_t size;
381 if (spec_size (ref->u.ar.as, &size))
383 if (mpz_cmp (offset, size) >= 0)
385 mpz_clear (size);
386 gfc_error ("Data element above array upper bound at %L",
387 &lvalue->where);
388 goto abort;
390 mpz_clear (size);
394 con = gfc_constructor_lookup (expr->value.constructor,
395 mpz_get_si (offset));
396 if (!con)
398 con = gfc_constructor_insert_expr (&expr->value.constructor,
399 NULL, &rvalue->where,
400 mpz_get_si (offset));
402 else if (mpz_cmp_si (con->repeat, 1) > 0)
404 /* Need to split a range. */
405 if (mpz_cmp (con->offset, offset) < 0)
407 gfc_constructor *pred_con = con;
408 con = gfc_constructor_insert_expr (&expr->value.constructor,
409 NULL, &con->where,
410 mpz_get_si (offset));
411 con->expr = gfc_copy_expr (pred_con->expr);
412 mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
413 mpz_sub (con->repeat, con->repeat, offset);
414 mpz_sub (pred_con->repeat, offset, pred_con->offset);
416 if (mpz_cmp_si (con->repeat, 1) > 0)
418 gfc_constructor *succ_con;
419 succ_con
420 = gfc_constructor_insert_expr (&expr->value.constructor,
421 NULL, &con->where,
422 mpz_get_si (offset) + 1);
423 succ_con->expr = gfc_copy_expr (con->expr);
424 mpz_sub_ui (succ_con->repeat, con->repeat, 1);
425 mpz_set_si (con->repeat, 1);
428 break;
430 case REF_COMPONENT:
431 if (init == NULL)
433 /* Setup the expression to hold the constructor. */
434 expr->expr_type = EXPR_STRUCTURE;
435 expr->ts.type = BT_DERIVED;
436 expr->ts.u.derived = ref->u.c.sym;
438 else
439 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
440 last_ts = &ref->u.c.component->ts;
442 /* Find the same element in the existing constructor. */
443 con = find_con_by_component (ref->u.c.component,
444 expr->value.constructor);
446 if (con == NULL)
448 /* Create a new constructor. */
449 con = gfc_constructor_append_expr (&expr->value.constructor,
450 NULL, NULL);
451 con->n.component = ref->u.c.component;
453 break;
455 default:
456 gcc_unreachable ();
459 if (init == NULL)
461 /* Point the container at the new expression. */
462 if (last_con == NULL)
463 symbol->value = expr;
464 else
465 last_con->expr = expr;
467 init = con->expr;
468 last_con = con;
471 mpz_clear (offset);
472 gcc_assert (repeat == NULL);
474 if (ref || last_ts->type == BT_CHARACTER)
476 if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
477 return false;
478 expr = create_character_initializer (init, last_ts, ref, rvalue);
480 else
482 /* Overwriting an existing initializer is non-standard but usually only
483 provokes a warning from other compilers. */
484 if (init != NULL)
486 /* Order in which the expressions arrive here depends on whether
487 they are from data statements or F95 style declarations.
488 Therefore, check which is the most recent. */
489 expr = (LOCATION_LINE (init->where.lb->location)
490 > LOCATION_LINE (rvalue->where.lb->location))
491 ? init : rvalue;
492 if (gfc_notify_std (GFC_STD_GNU,
493 "re-initialization of '%s' at %L",
494 symbol->name, &expr->where) == false)
495 return false;
498 expr = gfc_copy_expr (rvalue);
499 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
500 gfc_convert_type (expr, &lvalue->ts, 0);
503 if (last_con == NULL)
504 symbol->value = expr;
505 else
506 last_con->expr = expr;
508 return true;
510 abort:
511 if (!init)
512 gfc_free_expr (expr);
513 mpz_clear (offset);
514 return false;
518 /* Modify the index of array section and re-calculate the array offset. */
520 void
521 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
522 mpz_t *offset_ret)
524 int i;
525 mpz_t delta;
526 mpz_t tmp;
527 bool forwards;
528 int cmp;
530 for (i = 0; i < ar->dimen; i++)
532 if (ar->dimen_type[i] != DIMEN_RANGE)
533 continue;
535 if (ar->stride[i])
537 mpz_add (section_index[i], section_index[i],
538 ar->stride[i]->value.integer);
539 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
540 forwards = true;
541 else
542 forwards = false;
544 else
546 mpz_add_ui (section_index[i], section_index[i], 1);
547 forwards = true;
550 if (ar->end[i])
551 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
552 else
553 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
555 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
557 /* Reset index to start, then loop to advance the next index. */
558 if (ar->start[i])
559 mpz_set (section_index[i], ar->start[i]->value.integer);
560 else
561 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
563 else
564 break;
567 mpz_set_si (*offset_ret, 0);
568 mpz_init_set_si (delta, 1);
569 mpz_init (tmp);
570 for (i = 0; i < ar->dimen; i++)
572 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
573 mpz_mul (tmp, tmp, delta);
574 mpz_add (*offset_ret, tmp, *offset_ret);
576 mpz_sub (tmp, ar->as->upper[i]->value.integer,
577 ar->as->lower[i]->value.integer);
578 mpz_add_ui (tmp, tmp, 1);
579 mpz_mul (delta, tmp, delta);
581 mpz_clear (tmp);
582 mpz_clear (delta);
586 /* Rearrange a structure constructor so the elements are in the specified
587 order. Also insert NULL entries if necessary. */
589 static void
590 formalize_structure_cons (gfc_expr *expr)
592 gfc_constructor_base base = NULL;
593 gfc_constructor *cur;
594 gfc_component *order;
596 /* Constructor is already formalized. */
597 cur = gfc_constructor_first (expr->value.constructor);
598 if (!cur || cur->n.component == NULL)
599 return;
601 for (order = expr->ts.u.derived->components; order; order = order->next)
603 cur = find_con_by_component (order, expr->value.constructor);
604 if (cur)
605 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
606 else
607 gfc_constructor_append_expr (&base, NULL, NULL);
610 /* For all what it's worth, one would expect
611 gfc_constructor_free (expr->value.constructor);
612 here. However, if the constructor is actually free'd,
613 hell breaks loose in the testsuite?! */
615 expr->value.constructor = base;
619 /* Make sure an initialization expression is in normalized form, i.e., all
620 elements of the constructors are in the correct order. */
622 static void
623 formalize_init_expr (gfc_expr *expr)
625 expr_t type;
626 gfc_constructor *c;
628 if (expr == NULL)
629 return;
631 type = expr->expr_type;
632 switch (type)
634 case EXPR_ARRAY:
635 for (c = gfc_constructor_first (expr->value.constructor);
636 c; c = gfc_constructor_next (c))
637 formalize_init_expr (c->expr);
639 break;
641 case EXPR_STRUCTURE:
642 formalize_structure_cons (expr);
643 break;
645 default:
646 break;
651 /* Resolve symbol's initial value after all data statement. */
653 void
654 gfc_formalize_init_value (gfc_symbol *sym)
656 formalize_init_expr (sym->value);
660 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
661 offset. */
663 void
664 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
666 int i;
667 mpz_t delta;
668 mpz_t tmp;
670 mpz_set_si (*offset, 0);
671 mpz_init (tmp);
672 mpz_init_set_si (delta, 1);
673 for (i = 0; i < ar->dimen; i++)
675 mpz_init (section_index[i]);
676 switch (ar->dimen_type[i])
678 case DIMEN_ELEMENT:
679 case DIMEN_RANGE:
680 if (ar->start[i])
682 mpz_sub (tmp, ar->start[i]->value.integer,
683 ar->as->lower[i]->value.integer);
684 mpz_mul (tmp, tmp, delta);
685 mpz_add (*offset, tmp, *offset);
686 mpz_set (section_index[i], ar->start[i]->value.integer);
688 else
689 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
690 break;
692 case DIMEN_VECTOR:
693 gfc_internal_error ("TODO: Vector sections in data statements");
695 default:
696 gcc_unreachable ();
699 mpz_sub (tmp, ar->as->upper[i]->value.integer,
700 ar->as->lower[i]->value.integer);
701 mpz_add_ui (tmp, tmp, 1);
702 mpz_mul (delta, tmp, delta);
705 mpz_clear (tmp);
706 mpz_clear (delta);