1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2013 Free Software Foundation, Inc.
3 Contributed by Lifang Zeng <zlf605@hotmail.com>
4
5 This file is part of GCC.
6
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.
11
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.
16
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/>. */
20
21
22 /* Notes for DATA statement implementation:
23
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.
27
28 The complexity exists in the handling of array section, implied do
29 and array of struct appeared in DATA statement.
30
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. */
34
35 #include "config.h"
36 #include "system.h"
37 #include "coretypes.h"
38 #include "gfortran.h"
39 #include "data.h"
40 #include "constructor.h"
41
42 static void formalize_init_expr (gfc_expr *);
43
44 /* Calculate the array element offset. */
45
46 static void
get_array_index(gfc_array_ref * ar,mpz_t * offset)47 get_array_index (gfc_array_ref *ar, mpz_t *offset)
48 {
49 gfc_expr *e;
50 int i;
51 mpz_t delta;
52 mpz_t tmp;
53
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++)
58 {
59 e = gfc_copy_expr (ar->start[i]);
60 gfc_simplify_expr (e, 1);
61
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);
66
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);
72
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);
77 }
78 mpz_clear (delta);
79 mpz_clear (tmp);
80 }
81
82 /* Find if there is a constructor which component is equal to COM.
83 TODO: remove this, use symbol.c(gfc_find_component) instead. */
84
85 static gfc_constructor *
find_con_by_component(gfc_component * com,gfc_constructor_base base)86 find_con_by_component (gfc_component *com, gfc_constructor_base base)
87 {
88 gfc_constructor *c;
89
90 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
91 if (com == c->n.component)
92 return c;
93
94 return NULL;
95 }
96
97
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. */
102
103 static gfc_expr *
create_character_initializer(gfc_expr * init,gfc_typespec * ts,gfc_ref * ref,gfc_expr * rvalue)104 create_character_initializer (gfc_expr *init, gfc_typespec *ts,
105 gfc_ref *ref, gfc_expr *rvalue)
106 {
107 int len, start, end;
108 gfc_char_t *dest;
109
110 gfc_extract_int (ts->u.cl->length, &len);
111
112 if (init == NULL)
113 {
114 /* Create a new initializer. */
115 init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
116 init->ts = *ts;
117 }
118
119 dest = init->value.character.string;
120
121 if (ref)
122 {
123 gfc_expr *start_expr, *end_expr;
124
125 gcc_assert (ref->type == REF_SUBSTRING);
126
127 /* Only set a substring of the destination. Fortran substring bounds
128 are one-based [start, end], we want zero based [start, end). */
129 start_expr = gfc_copy_expr (ref->u.ss.start);
130 end_expr = gfc_copy_expr (ref->u.ss.end);
131
132 if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
133 || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
134 {
135 gfc_error ("failure to simplify substring reference in DATA "
136 "statement at %L", &ref->u.ss.start->where);
137 return NULL;
138 }
139
140 gfc_extract_int (start_expr, &start);
141 gfc_free_expr (start_expr);
142 start--;
143 gfc_extract_int (end_expr, &end);
144 gfc_free_expr (end_expr);
145 }
146 else
147 {
148 /* Set the whole string. */
149 start = 0;
150 end = len;
151 }
152
153 /* Copy the initial value. */
154 if (rvalue->ts.type == BT_HOLLERITH)
155 len = rvalue->representation.length - rvalue->ts.u.pad;
156 else
157 len = rvalue->value.character.length;
158
159 if (len > end - start)
160 {
161 gfc_warning_now ("Initialization string starting at %L was "
162 "truncated to fit the variable (%d/%d)",
163 &rvalue->where, end - start, len);
164 len = end - start;
165 }
166
167 if (rvalue->ts.type == BT_HOLLERITH)
168 {
169 int i;
170 for (i = 0; i < len; i++)
171 dest[start+i] = rvalue->representation.string[i];
172 }
173 else
174 memcpy (&dest[start], rvalue->value.character.string,
175 len * sizeof (gfc_char_t));
176
177 /* Pad with spaces. Substrings will already be blanked. */
178 if (len < end - start && ref == NULL)
179 gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
180
181 if (rvalue->ts.type == BT_HOLLERITH)
182 {
183 init->representation.length = init->value.character.length;
184 init->representation.string
185 = gfc_widechar_to_char (init->value.character.string,
186 init->value.character.length);
187 }
188
189 return init;
190 }
191
192
193 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
194 LVALUE already has an initialization, we extend this, otherwise we
195 create a new one. If REPEAT is non-NULL, initialize *REPEAT
196 consecutive values in LVALUE the same value in RVALUE. In that case,
197 LVALUE must refer to a full array, not an array section. */
198
199 gfc_try
gfc_assign_data_value(gfc_expr * lvalue,gfc_expr * rvalue,mpz_t index,mpz_t * repeat)200 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
201 mpz_t *repeat)
202 {
203 gfc_ref *ref;
204 gfc_expr *init;
205 gfc_expr *expr = NULL;
206 gfc_constructor *con;
207 gfc_constructor *last_con;
208 gfc_symbol *symbol;
209 gfc_typespec *last_ts;
210 mpz_t offset;
211
212 symbol = lvalue->symtree->n.sym;
213 init = symbol->value;
214 last_ts = &symbol->ts;
215 last_con = NULL;
216 mpz_init_set_si (offset, 0);
217
218 /* Find/create the parent expressions for subobject references. */
219 for (ref = lvalue->ref; ref; ref = ref->next)
220 {
221 /* Break out of the loop if we find a substring. */
222 if (ref->type == REF_SUBSTRING)
223 {
224 /* A substring should always be the last subobject reference. */
225 gcc_assert (ref->next == NULL);
226 break;
227 }
228
229 /* Use the existing initializer expression if it exists. Otherwise
230 create a new one. */
231 if (init == NULL)
232 expr = gfc_get_expr ();
233 else
234 expr = init;
235
236 /* Find or create this element. */
237 switch (ref->type)
238 {
239 case REF_ARRAY:
240 if (ref->u.ar.as->rank == 0)
241 {
242 gcc_assert (ref->u.ar.as->corank > 0);
243 if (init == NULL)
244 free (expr);
245 continue;
246 }
247
248 if (init && expr->expr_type != EXPR_ARRAY)
249 {
250 gfc_error ("'%s' at %L already is initialized at %L",
251 lvalue->symtree->n.sym->name, &lvalue->where,
252 &init->where);
253 goto abort;
254 }
255
256 if (init == NULL)
257 {
258 /* The element typespec will be the same as the array
259 typespec. */
260 expr->ts = *last_ts;
261 /* Setup the expression to hold the constructor. */
262 expr->expr_type = EXPR_ARRAY;
263 expr->rank = ref->u.ar.as->rank;
264 }
265
266 if (ref->u.ar.type == AR_ELEMENT)
267 get_array_index (&ref->u.ar, &offset);
268 else
269 mpz_set (offset, index);
270
271 /* Check the bounds. */
272 if (mpz_cmp_si (offset, 0) < 0)
273 {
274 gfc_error ("Data element below array lower bound at %L",
275 &lvalue->where);
276 goto abort;
277 }
278 else if (repeat != NULL
279 && ref->u.ar.type != AR_ELEMENT)
280 {
281 mpz_t size, end;
282 gcc_assert (ref->u.ar.type == AR_FULL
283 && ref->next == NULL);
284 mpz_init_set (end, offset);
285 mpz_add (end, end, *repeat);
286 if (spec_size (ref->u.ar.as, &size) == SUCCESS)
287 {
288 if (mpz_cmp (end, size) > 0)
289 {
290 mpz_clear (size);
291 gfc_error ("Data element above array upper bound at %L",
292 &lvalue->where);
293 goto abort;
294 }
295 mpz_clear (size);
296 }
297
298 con = gfc_constructor_lookup (expr->value.constructor,
299 mpz_get_si (offset));
300 if (!con)
301 {
302 con = gfc_constructor_lookup_next (expr->value.constructor,
303 mpz_get_si (offset));
304 if (con != NULL && mpz_cmp (con->offset, end) >= 0)
305 con = NULL;
306 }
307
308 /* Overwriting an existing initializer is non-standard but
309 usually only provokes a warning from other compilers. */
310 if (con != NULL && con->expr != NULL)
311 {
312 /* Order in which the expressions arrive here depends on
313 whether they are from data statements or F95 style
314 declarations. Therefore, check which is the most
315 recent. */
316 gfc_expr *exprd;
317 exprd = (LOCATION_LINE (con->expr->where.lb->location)
318 > LOCATION_LINE (rvalue->where.lb->location))
319 ? con->expr : rvalue;
320 if (gfc_notify_std (GFC_STD_GNU,
321 "re-initialization of '%s' at %L",
322 symbol->name, &exprd->where) == FAILURE)
323 return FAILURE;
324 }
325
326 while (con != NULL)
327 {
328 gfc_constructor *next_con = gfc_constructor_next (con);
329
330 if (mpz_cmp (con->offset, end) >= 0)
331 break;
332 if (mpz_cmp (con->offset, offset) < 0)
333 {
334 gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
335 mpz_sub (con->repeat, offset, con->offset);
336 }
337 else if (mpz_cmp_si (con->repeat, 1) > 0
338 && mpz_get_si (con->offset)
339 + mpz_get_si (con->repeat) > mpz_get_si (end))
340 {
341 int endi;
342 splay_tree_node node
343 = splay_tree_lookup (con->base,
344 mpz_get_si (con->offset));
345 gcc_assert (node
346 && con == (gfc_constructor *) node->value
347 && node->key == (splay_tree_key)
348 mpz_get_si (con->offset));
349 endi = mpz_get_si (con->offset)
350 + mpz_get_si (con->repeat);
351 if (endi > mpz_get_si (end) + 1)
352 mpz_set_si (con->repeat, endi - mpz_get_si (end));
353 else
354 mpz_set_si (con->repeat, 1);
355 mpz_set (con->offset, end);
356 node->key = (splay_tree_key) mpz_get_si (end);
357 break;
358 }
359 else
360 gfc_constructor_remove (con);
361 con = next_con;
362 }
363
364 con = gfc_constructor_insert_expr (&expr->value.constructor,
365 NULL, &rvalue->where,
366 mpz_get_si (offset));
367 mpz_set (con->repeat, *repeat);
368 repeat = NULL;
369 mpz_clear (end);
370 break;
371 }
372 else
373 {
374 mpz_t size;
375 if (spec_size (ref->u.ar.as, &size) == SUCCESS)
376 {
377 if (mpz_cmp (offset, size) >= 0)
378 {
379 mpz_clear (size);
380 gfc_error ("Data element above array upper bound at %L",
381 &lvalue->where);
382 goto abort;
383 }
384 mpz_clear (size);
385 }
386 }
387
388 con = gfc_constructor_lookup (expr->value.constructor,
389 mpz_get_si (offset));
390 if (!con)
391 {
392 con = gfc_constructor_insert_expr (&expr->value.constructor,
393 NULL, &rvalue->where,
394 mpz_get_si (offset));
395 }
396 else if (mpz_cmp_si (con->repeat, 1) > 0)
397 {
398 /* Need to split a range. */
399 if (mpz_cmp (con->offset, offset) < 0)
400 {
401 gfc_constructor *pred_con = con;
402 con = gfc_constructor_insert_expr (&expr->value.constructor,
403 NULL, &con->where,
404 mpz_get_si (offset));
405 con->expr = gfc_copy_expr (pred_con->expr);
406 mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
407 mpz_sub (con->repeat, con->repeat, offset);
408 mpz_sub (pred_con->repeat, offset, pred_con->offset);
409 }
410 if (mpz_cmp_si (con->repeat, 1) > 0)
411 {
412 gfc_constructor *succ_con;
413 succ_con
414 = gfc_constructor_insert_expr (&expr->value.constructor,
415 NULL, &con->where,
416 mpz_get_si (offset) + 1);
417 succ_con->expr = gfc_copy_expr (con->expr);
418 mpz_sub_ui (succ_con->repeat, con->repeat, 1);
419 mpz_set_si (con->repeat, 1);
420 }
421 }
422 break;
423
424 case REF_COMPONENT:
425 if (init == NULL)
426 {
427 /* Setup the expression to hold the constructor. */
428 expr->expr_type = EXPR_STRUCTURE;
429 expr->ts.type = BT_DERIVED;
430 expr->ts.u.derived = ref->u.c.sym;
431 }
432 else
433 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
434 last_ts = &ref->u.c.component->ts;
435
436 /* Find the same element in the existing constructor. */
437 con = find_con_by_component (ref->u.c.component,
438 expr->value.constructor);
439
440 if (con == NULL)
441 {
442 /* Create a new constructor. */
443 con = gfc_constructor_append_expr (&expr->value.constructor,
444 NULL, NULL);
445 con->n.component = ref->u.c.component;
446 }
447 break;
448
449 default:
450 gcc_unreachable ();
451 }
452
453 if (init == NULL)
454 {
455 /* Point the container at the new expression. */
456 if (last_con == NULL)
457 symbol->value = expr;
458 else
459 last_con->expr = expr;
460 }
461 init = con->expr;
462 last_con = con;
463 }
464
465 mpz_clear (offset);
466 gcc_assert (repeat == NULL);
467
468 if (ref || last_ts->type == BT_CHARACTER)
469 {
470 if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
471 return FAILURE;
472 expr = create_character_initializer (init, last_ts, ref, rvalue);
473 }
474 else
475 {
476 /* Overwriting an existing initializer is non-standard but usually only
477 provokes a warning from other compilers. */
478 if (init != NULL)
479 {
480 /* Order in which the expressions arrive here depends on whether
481 they are from data statements or F95 style declarations.
482 Therefore, check which is the most recent. */
483 expr = (LOCATION_LINE (init->where.lb->location)
484 > LOCATION_LINE (rvalue->where.lb->location))
485 ? init : rvalue;
486 if (gfc_notify_std (GFC_STD_GNU,
487 "re-initialization of '%s' at %L",
488 symbol->name, &expr->where) == FAILURE)
489 return FAILURE;
490 }
491
492 expr = gfc_copy_expr (rvalue);
493 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
494 gfc_convert_type (expr, &lvalue->ts, 0);
495 }
496
497 if (last_con == NULL)
498 symbol->value = expr;
499 else
500 last_con->expr = expr;
501
502 return SUCCESS;
503
504 abort:
505 if (!init)
506 gfc_free_expr (expr);
507 mpz_clear (offset);
508 return FAILURE;
509 }
510
511
512 /* Modify the index of array section and re-calculate the array offset. */
513
514 void
gfc_advance_section(mpz_t * section_index,gfc_array_ref * ar,mpz_t * offset_ret)515 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
516 mpz_t *offset_ret)
517 {
518 int i;
519 mpz_t delta;
520 mpz_t tmp;
521 bool forwards;
522 int cmp;
523
524 for (i = 0; i < ar->dimen; i++)
525 {
526 if (ar->dimen_type[i] != DIMEN_RANGE)
527 continue;
528
529 if (ar->stride[i])
530 {
531 mpz_add (section_index[i], section_index[i],
532 ar->stride[i]->value.integer);
533 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
534 forwards = true;
535 else
536 forwards = false;
537 }
538 else
539 {
540 mpz_add_ui (section_index[i], section_index[i], 1);
541 forwards = true;
542 }
543
544 if (ar->end[i])
545 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
546 else
547 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
548
549 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
550 {
551 /* Reset index to start, then loop to advance the next index. */
552 if (ar->start[i])
553 mpz_set (section_index[i], ar->start[i]->value.integer);
554 else
555 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
556 }
557 else
558 break;
559 }
560
561 mpz_set_si (*offset_ret, 0);
562 mpz_init_set_si (delta, 1);
563 mpz_init (tmp);
564 for (i = 0; i < ar->dimen; i++)
565 {
566 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
567 mpz_mul (tmp, tmp, delta);
568 mpz_add (*offset_ret, tmp, *offset_ret);
569
570 mpz_sub (tmp, ar->as->upper[i]->value.integer,
571 ar->as->lower[i]->value.integer);
572 mpz_add_ui (tmp, tmp, 1);
573 mpz_mul (delta, tmp, delta);
574 }
575 mpz_clear (tmp);
576 mpz_clear (delta);
577 }
578
579
580 /* Rearrange a structure constructor so the elements are in the specified
581 order. Also insert NULL entries if necessary. */
582
583 static void
formalize_structure_cons(gfc_expr * expr)584 formalize_structure_cons (gfc_expr *expr)
585 {
586 gfc_constructor_base base = NULL;
587 gfc_constructor *cur;
588 gfc_component *order;
589
590 /* Constructor is already formalized. */
591 cur = gfc_constructor_first (expr->value.constructor);
592 if (!cur || cur->n.component == NULL)
593 return;
594
595 for (order = expr->ts.u.derived->components; order; order = order->next)
596 {
597 cur = find_con_by_component (order, expr->value.constructor);
598 if (cur)
599 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
600 else
601 gfc_constructor_append_expr (&base, NULL, NULL);
602 }
603
604 /* For all what it's worth, one would expect
605 gfc_constructor_free (expr->value.constructor);
606 here. However, if the constructor is actually free'd,
607 hell breaks loose in the testsuite?! */
608
609 expr->value.constructor = base;
610 }
611
612
613 /* Make sure an initialization expression is in normalized form, i.e., all
614 elements of the constructors are in the correct order. */
615
616 static void
formalize_init_expr(gfc_expr * expr)617 formalize_init_expr (gfc_expr *expr)
618 {
619 expr_t type;
620 gfc_constructor *c;
621
622 if (expr == NULL)
623 return;
624
625 type = expr->expr_type;
626 switch (type)
627 {
628 case EXPR_ARRAY:
629 for (c = gfc_constructor_first (expr->value.constructor);
630 c; c = gfc_constructor_next (c))
631 formalize_init_expr (c->expr);
632
633 break;
634
635 case EXPR_STRUCTURE:
636 formalize_structure_cons (expr);
637 break;
638
639 default:
640 break;
641 }
642 }
643
644
645 /* Resolve symbol's initial value after all data statement. */
646
647 void
gfc_formalize_init_value(gfc_symbol * sym)648 gfc_formalize_init_value (gfc_symbol *sym)
649 {
650 formalize_init_expr (sym->value);
651 }
652
653
654 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
655 offset. */
656
657 void
gfc_get_section_index(gfc_array_ref * ar,mpz_t * section_index,mpz_t * offset)658 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
659 {
660 int i;
661 mpz_t delta;
662 mpz_t tmp;
663
664 mpz_set_si (*offset, 0);
665 mpz_init (tmp);
666 mpz_init_set_si (delta, 1);
667 for (i = 0; i < ar->dimen; i++)
668 {
669 mpz_init (section_index[i]);
670 switch (ar->dimen_type[i])
671 {
672 case DIMEN_ELEMENT:
673 case DIMEN_RANGE:
674 if (ar->start[i])
675 {
676 mpz_sub (tmp, ar->start[i]->value.integer,
677 ar->as->lower[i]->value.integer);
678 mpz_mul (tmp, tmp, delta);
679 mpz_add (*offset, tmp, *offset);
680 mpz_set (section_index[i], ar->start[i]->value.integer);
681 }
682 else
683 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
684 break;
685
686 case DIMEN_VECTOR:
687 gfc_internal_error ("TODO: Vector sections in data statements");
688
689 default:
690 gcc_unreachable ();
691 }
692
693 mpz_sub (tmp, ar->as->upper[i]->value.integer,
694 ar->as->lower[i]->value.integer);
695 mpz_add_ui (tmp, tmp, 1);
696 mpz_mul (delta, tmp, delta);
697 }
698
699 mpz_clear (tmp);
700 mpz_clear (delta);
701 }
702
703