1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2019 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 HOST_WIDE_INT len, start, end, tlen;
108 gfc_char_t *dest;
109 bool alloced_init = false;
110
111 if (init && init->ts.type != BT_CHARACTER)
112 return NULL;
113
114 gfc_extract_hwi (ts->u.cl->length, &len);
115
116 if (init == NULL)
117 {
118 /* Create a new initializer. */
119 init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
120 init->ts = *ts;
121 alloced_init = true;
122 }
123
124 dest = init->value.character.string;
125
126 if (ref)
127 {
128 gfc_expr *start_expr, *end_expr;
129
130 gcc_assert (ref->type == REF_SUBSTRING);
131
132 /* Only set a substring of the destination. Fortran substring bounds
133 are one-based [start, end], we want zero based [start, end). */
134 start_expr = gfc_copy_expr (ref->u.ss.start);
135 end_expr = gfc_copy_expr (ref->u.ss.end);
136
137 if ((!gfc_simplify_expr(start_expr, 1))
138 || !(gfc_simplify_expr(end_expr, 1)))
139 {
140 gfc_error ("failure to simplify substring reference in DATA "
141 "statement at %L", &ref->u.ss.start->where);
142 gfc_free_expr (start_expr);
143 gfc_free_expr (end_expr);
144 if (alloced_init)
145 gfc_free_expr (init);
146 return NULL;
147 }
148
149 gfc_extract_hwi (start_expr, &start);
150 gfc_free_expr (start_expr);
151 start--;
152 gfc_extract_hwi (end_expr, &end);
153 gfc_free_expr (end_expr);
154 }
155 else
156 {
157 /* Set the whole string. */
158 start = 0;
159 end = len;
160 }
161
162 /* Copy the initial value. */
163 if (rvalue->ts.type == BT_HOLLERITH)
164 len = rvalue->representation.length - rvalue->ts.u.pad;
165 else
166 len = rvalue->value.character.length;
167
168 tlen = end - start;
169 if (len > tlen)
170 {
171 if (tlen < 0)
172 {
173 gfc_warning_now (0, "Unused initialization string at %L because "
174 "variable has zero length", &rvalue->where);
175 len = 0;
176 }
177 else
178 {
179 gfc_warning_now (0, "Initialization string at %L was truncated to "
180 "fit the variable (%ld/%ld)", &rvalue->where,
181 (long) tlen, (long) len);
182 len = tlen;
183 }
184 }
185
186 if (rvalue->ts.type == BT_HOLLERITH)
187 {
188 for (size_t i = 0; i < (size_t) len; i++)
189 dest[start+i] = rvalue->representation.string[i];
190 }
191 else
192 memcpy (&dest[start], rvalue->value.character.string,
193 len * sizeof (gfc_char_t));
194
195 /* Pad with spaces. Substrings will already be blanked. */
196 if (len < tlen && ref == NULL)
197 gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
198
199 if (rvalue->ts.type == BT_HOLLERITH)
200 {
201 init->representation.length = init->value.character.length;
202 init->representation.string
203 = gfc_widechar_to_char (init->value.character.string,
204 init->value.character.length);
205 }
206
207 return init;
208 }
209
210
211 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
212 LVALUE already has an initialization, we extend this, otherwise we
213 create a new one. If REPEAT is non-NULL, initialize *REPEAT
214 consecutive values in LVALUE the same value in RVALUE. In that case,
215 LVALUE must refer to a full array, not an array section. */
216
217 bool
gfc_assign_data_value(gfc_expr * lvalue,gfc_expr * rvalue,mpz_t index,mpz_t * repeat)218 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
219 mpz_t *repeat)
220 {
221 gfc_ref *ref;
222 gfc_expr *init;
223 gfc_expr *expr = NULL;
224 gfc_expr *rexpr;
225 gfc_constructor *con;
226 gfc_constructor *last_con;
227 gfc_symbol *symbol;
228 gfc_typespec *last_ts;
229 mpz_t offset;
230 const char *msg = "F18(R841): data-implied-do object at %L is neither an "
231 "array-element nor a scalar-structure-component";
232
233 symbol = lvalue->symtree->n.sym;
234 init = symbol->value;
235 last_ts = &symbol->ts;
236 last_con = NULL;
237 mpz_init_set_si (offset, 0);
238
239 /* Find/create the parent expressions for subobject references. */
240 for (ref = lvalue->ref; ref; ref = ref->next)
241 {
242 /* Break out of the loop if we find a substring. */
243 if (ref->type == REF_SUBSTRING)
244 {
245 /* A substring should always be the last subobject reference. */
246 gcc_assert (ref->next == NULL);
247 break;
248 }
249
250 /* Use the existing initializer expression if it exists. Otherwise
251 create a new one. */
252 if (init == NULL)
253 expr = gfc_get_expr ();
254 else
255 expr = init;
256
257 /* Find or create this element. */
258 switch (ref->type)
259 {
260 case REF_ARRAY:
261 if (ref->u.ar.as->rank == 0)
262 {
263 gcc_assert (ref->u.ar.as->corank > 0);
264 if (init == NULL)
265 free (expr);
266 continue;
267 }
268
269 if (init && expr->expr_type != EXPR_ARRAY)
270 {
271 gfc_error ("%qs at %L already is initialized at %L",
272 lvalue->symtree->n.sym->name, &lvalue->where,
273 &init->where);
274 goto abort;
275 }
276
277 if (init == NULL)
278 {
279 /* The element typespec will be the same as the array
280 typespec. */
281 expr->ts = *last_ts;
282 /* Setup the expression to hold the constructor. */
283 expr->expr_type = EXPR_ARRAY;
284 expr->rank = ref->u.ar.as->rank;
285 }
286
287 if (ref->u.ar.type == AR_ELEMENT)
288 get_array_index (&ref->u.ar, &offset);
289 else
290 mpz_set (offset, index);
291
292 /* Check the bounds. */
293 if (mpz_cmp_si (offset, 0) < 0)
294 {
295 gfc_error ("Data element below array lower bound at %L",
296 &lvalue->where);
297 goto abort;
298 }
299 else if (repeat != NULL
300 && ref->u.ar.type != AR_ELEMENT)
301 {
302 mpz_t size, end;
303 gcc_assert (ref->u.ar.type == AR_FULL
304 && ref->next == NULL);
305 mpz_init_set (end, offset);
306 mpz_add (end, end, *repeat);
307 if (spec_size (ref->u.ar.as, &size))
308 {
309 if (mpz_cmp (end, size) > 0)
310 {
311 mpz_clear (size);
312 gfc_error ("Data element above array upper bound at %L",
313 &lvalue->where);
314 goto abort;
315 }
316 mpz_clear (size);
317 }
318
319 con = gfc_constructor_lookup (expr->value.constructor,
320 mpz_get_si (offset));
321 if (!con)
322 {
323 con = gfc_constructor_lookup_next (expr->value.constructor,
324 mpz_get_si (offset));
325 if (con != NULL && mpz_cmp (con->offset, end) >= 0)
326 con = NULL;
327 }
328
329 /* Overwriting an existing initializer is non-standard but
330 usually only provokes a warning from other compilers. */
331 if (con != NULL && con->expr != NULL)
332 {
333 /* Order in which the expressions arrive here depends on
334 whether they are from data statements or F95 style
335 declarations. Therefore, check which is the most
336 recent. */
337 gfc_expr *exprd;
338 exprd = (LOCATION_LINE (con->expr->where.lb->location)
339 > LOCATION_LINE (rvalue->where.lb->location))
340 ? con->expr : rvalue;
341 if (gfc_notify_std (GFC_STD_GNU,
342 "re-initialization of %qs at %L",
343 symbol->name, &exprd->where) == false)
344 return false;
345 }
346
347 while (con != NULL)
348 {
349 gfc_constructor *next_con = gfc_constructor_next (con);
350
351 if (mpz_cmp (con->offset, end) >= 0)
352 break;
353 if (mpz_cmp (con->offset, offset) < 0)
354 {
355 gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
356 mpz_sub (con->repeat, offset, con->offset);
357 }
358 else if (mpz_cmp_si (con->repeat, 1) > 0
359 && mpz_get_si (con->offset)
360 + mpz_get_si (con->repeat) > mpz_get_si (end))
361 {
362 int endi;
363 splay_tree_node node
364 = splay_tree_lookup (con->base,
365 mpz_get_si (con->offset));
366 gcc_assert (node
367 && con == (gfc_constructor *) node->value
368 && node->key == (splay_tree_key)
369 mpz_get_si (con->offset));
370 endi = mpz_get_si (con->offset)
371 + mpz_get_si (con->repeat);
372 if (endi > mpz_get_si (end) + 1)
373 mpz_set_si (con->repeat, endi - mpz_get_si (end));
374 else
375 mpz_set_si (con->repeat, 1);
376 mpz_set (con->offset, end);
377 node->key = (splay_tree_key) mpz_get_si (end);
378 break;
379 }
380 else
381 gfc_constructor_remove (con);
382 con = next_con;
383 }
384
385 con = gfc_constructor_insert_expr (&expr->value.constructor,
386 NULL, &rvalue->where,
387 mpz_get_si (offset));
388 mpz_set (con->repeat, *repeat);
389 repeat = NULL;
390 mpz_clear (end);
391 break;
392 }
393 else
394 {
395 mpz_t size;
396 if (spec_size (ref->u.ar.as, &size))
397 {
398 if (mpz_cmp (offset, size) >= 0)
399 {
400 mpz_clear (size);
401 gfc_error ("Data element above array upper bound at %L",
402 &lvalue->where);
403 goto abort;
404 }
405 mpz_clear (size);
406 }
407 }
408
409 con = gfc_constructor_lookup (expr->value.constructor,
410 mpz_get_si (offset));
411 if (!con)
412 {
413 con = gfc_constructor_insert_expr (&expr->value.constructor,
414 NULL, &rvalue->where,
415 mpz_get_si (offset));
416 }
417 else if (mpz_cmp_si (con->repeat, 1) > 0)
418 {
419 /* Need to split a range. */
420 if (mpz_cmp (con->offset, offset) < 0)
421 {
422 gfc_constructor *pred_con = con;
423 con = gfc_constructor_insert_expr (&expr->value.constructor,
424 NULL, &con->where,
425 mpz_get_si (offset));
426 con->expr = gfc_copy_expr (pred_con->expr);
427 mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
428 mpz_sub (con->repeat, con->repeat, offset);
429 mpz_sub (pred_con->repeat, offset, pred_con->offset);
430 }
431 if (mpz_cmp_si (con->repeat, 1) > 0)
432 {
433 gfc_constructor *succ_con;
434 succ_con
435 = gfc_constructor_insert_expr (&expr->value.constructor,
436 NULL, &con->where,
437 mpz_get_si (offset) + 1);
438 succ_con->expr = gfc_copy_expr (con->expr);
439 mpz_sub_ui (succ_con->repeat, con->repeat, 1);
440 mpz_set_si (con->repeat, 1);
441 }
442 }
443 break;
444
445 case REF_COMPONENT:
446 if (init == NULL)
447 {
448 /* Setup the expression to hold the constructor. */
449 expr->expr_type = EXPR_STRUCTURE;
450 expr->ts.type = BT_DERIVED;
451 expr->ts.u.derived = ref->u.c.sym;
452 }
453 else
454 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
455 last_ts = &ref->u.c.component->ts;
456
457 /* Find the same element in the existing constructor. */
458 con = find_con_by_component (ref->u.c.component,
459 expr->value.constructor);
460
461 if (con == NULL)
462 {
463 /* Create a new constructor. */
464 con = gfc_constructor_append_expr (&expr->value.constructor,
465 NULL, NULL);
466 con->n.component = ref->u.c.component;
467 }
468 break;
469
470 case REF_INQUIRY:
471
472 /* After some discussion on clf it was determined that the following
473 violates F18(R841). If the error is removed, the expected result
474 is obtained. Leaving the code in place ensures a clean error
475 recovery. */
476 gfc_error (msg, &lvalue->where);
477
478 /* This breaks with the other reference types in that the output
479 constructor has to be of type COMPLEX, whereas the lvalue is
480 of type REAL. The rvalue is copied to the real or imaginary
481 part as appropriate. In addition, for all except scalar
482 complex variables, a complex expression has to provided, where
483 the constructor does not have it, and the expression modified
484 with a new value for the real or imaginary part. */
485 gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX);
486 rexpr = gfc_copy_expr (rvalue);
487 if (!gfc_compare_types (&lvalue->ts, &rexpr->ts))
488 gfc_convert_type (rexpr, &lvalue->ts, 0);
489
490 /* This is the scalar, complex case, where an initializer exists. */
491 if (init && ref == lvalue->ref)
492 expr = symbol->value;
493 /* Then all cases, where a complex expression does not exist. */
494 else if (!last_con || !last_con->expr)
495 {
496 expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind,
497 &lvalue->where);
498 if (last_con)
499 last_con->expr = expr;
500 }
501 else
502 /* Finally, and existing constructor expression to be modified. */
503 expr = last_con->expr;
504
505 /* Rejection of LEN and KIND inquiry references is handled
506 elsewhere. The error here is added as backup. The assertion
507 of F2008 for RE and IM is also done elsewhere. */
508 switch (ref->u.i)
509 {
510 case INQUIRY_LEN:
511 case INQUIRY_KIND:
512 gfc_error ("LEN or KIND inquiry ref in DATA statement at %L",
513 &lvalue->where);
514 goto abort;
515 case INQUIRY_RE:
516 mpfr_set (mpc_realref (expr->value.complex),
517 rexpr->value.real,
518 GFC_RND_MODE);
519 break;
520 case INQUIRY_IM:
521 mpfr_set (mpc_imagref (expr->value.complex),
522 rexpr->value.real,
523 GFC_RND_MODE);
524 break;
525 }
526
527 /* Only the scalar, complex expression needs to be saved as the
528 symbol value since the last constructor expression is already
529 provided as the initializer in the code after the reference
530 cases. */
531 if (ref == lvalue->ref)
532 symbol->value = expr;
533
534 gfc_free_expr (rexpr);
535 mpz_clear (offset);
536 return true;
537
538 default:
539 gcc_unreachable ();
540 }
541
542 if (init == NULL)
543 {
544 /* Point the container at the new expression. */
545 if (last_con == NULL)
546 symbol->value = expr;
547 else
548 last_con->expr = expr;
549 }
550 init = con->expr;
551 last_con = con;
552 }
553
554 mpz_clear (offset);
555 gcc_assert (repeat == NULL);
556
557 /* Overwriting an existing initializer is non-standard but usually only
558 provokes a warning from other compilers. */
559 if (init != NULL && init->where.lb && rvalue->where.lb)
560 {
561 /* Order in which the expressions arrive here depends on whether
562 they are from data statements or F95 style declarations.
563 Therefore, check which is the most recent. */
564 expr = (LOCATION_LINE (init->where.lb->location)
565 > LOCATION_LINE (rvalue->where.lb->location))
566 ? init : rvalue;
567 if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
568 symbol->name, &expr->where) == false)
569 return false;
570 }
571
572 if (ref || (last_ts->type == BT_CHARACTER
573 && rvalue->expr_type == EXPR_CONSTANT))
574 {
575 /* An initializer has to be constant. */
576 if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
577 return false;
578 expr = create_character_initializer (init, last_ts, ref, rvalue);
579 }
580 else
581 {
582 if (lvalue->ts.type == BT_DERIVED
583 && gfc_has_default_initializer (lvalue->ts.u.derived))
584 {
585 gfc_error ("Nonpointer object %qs with default initialization "
586 "shall not appear in a DATA statement at %L",
587 symbol->name, &lvalue->where);
588 return false;
589 }
590
591 expr = gfc_copy_expr (rvalue);
592 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
593 gfc_convert_type (expr, &lvalue->ts, 0);
594 }
595
596 if (last_con == NULL)
597 symbol->value = expr;
598 else
599 last_con->expr = expr;
600
601 return true;
602
603 abort:
604 if (!init)
605 gfc_free_expr (expr);
606 mpz_clear (offset);
607 return false;
608 }
609
610
611 /* Modify the index of array section and re-calculate the array offset. */
612
613 void
gfc_advance_section(mpz_t * section_index,gfc_array_ref * ar,mpz_t * offset_ret)614 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
615 mpz_t *offset_ret)
616 {
617 int i;
618 mpz_t delta;
619 mpz_t tmp;
620 bool forwards;
621 int cmp;
622 gfc_expr *start, *end, *stride;
623
624 for (i = 0; i < ar->dimen; i++)
625 {
626 if (ar->dimen_type[i] != DIMEN_RANGE)
627 continue;
628
629 if (ar->stride[i])
630 {
631 stride = gfc_copy_expr(ar->stride[i]);
632 if(!gfc_simplify_expr(stride, 1))
633 gfc_internal_error("Simplification error");
634 mpz_add (section_index[i], section_index[i],
635 stride->value.integer);
636 if (mpz_cmp_si (stride->value.integer, 0) >= 0)
637 forwards = true;
638 else
639 forwards = false;
640 gfc_free_expr(stride);
641 }
642 else
643 {
644 mpz_add_ui (section_index[i], section_index[i], 1);
645 forwards = true;
646 }
647
648 if (ar->end[i])
649 {
650 end = gfc_copy_expr(ar->end[i]);
651 if(!gfc_simplify_expr(end, 1))
652 gfc_internal_error("Simplification error");
653 cmp = mpz_cmp (section_index[i], end->value.integer);
654 gfc_free_expr(end);
655 }
656 else
657 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
658
659 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
660 {
661 /* Reset index to start, then loop to advance the next index. */
662 if (ar->start[i])
663 {
664 start = gfc_copy_expr(ar->start[i]);
665 if(!gfc_simplify_expr(start, 1))
666 gfc_internal_error("Simplification error");
667 mpz_set (section_index[i], start->value.integer);
668 gfc_free_expr(start);
669 }
670 else
671 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
672 }
673 else
674 break;
675 }
676
677 mpz_set_si (*offset_ret, 0);
678 mpz_init_set_si (delta, 1);
679 mpz_init (tmp);
680 for (i = 0; i < ar->dimen; i++)
681 {
682 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
683 mpz_mul (tmp, tmp, delta);
684 mpz_add (*offset_ret, tmp, *offset_ret);
685
686 mpz_sub (tmp, ar->as->upper[i]->value.integer,
687 ar->as->lower[i]->value.integer);
688 mpz_add_ui (tmp, tmp, 1);
689 mpz_mul (delta, tmp, delta);
690 }
691 mpz_clear (tmp);
692 mpz_clear (delta);
693 }
694
695
696 /* Rearrange a structure constructor so the elements are in the specified
697 order. Also insert NULL entries if necessary. */
698
699 static void
formalize_structure_cons(gfc_expr * expr)700 formalize_structure_cons (gfc_expr *expr)
701 {
702 gfc_constructor_base base = NULL;
703 gfc_constructor *cur;
704 gfc_component *order;
705
706 /* Constructor is already formalized. */
707 cur = gfc_constructor_first (expr->value.constructor);
708 if (!cur || cur->n.component == NULL)
709 return;
710
711 for (order = expr->ts.u.derived->components; order; order = order->next)
712 {
713 cur = find_con_by_component (order, expr->value.constructor);
714 if (cur)
715 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
716 else
717 gfc_constructor_append_expr (&base, NULL, NULL);
718 }
719
720 /* For all what it's worth, one would expect
721 gfc_constructor_free (expr->value.constructor);
722 here. However, if the constructor is actually free'd,
723 hell breaks loose in the testsuite?! */
724
725 expr->value.constructor = base;
726 }
727
728
729 /* Make sure an initialization expression is in normalized form, i.e., all
730 elements of the constructors are in the correct order. */
731
732 static void
formalize_init_expr(gfc_expr * expr)733 formalize_init_expr (gfc_expr *expr)
734 {
735 expr_t type;
736 gfc_constructor *c;
737
738 if (expr == NULL)
739 return;
740
741 type = expr->expr_type;
742 switch (type)
743 {
744 case EXPR_ARRAY:
745 for (c = gfc_constructor_first (expr->value.constructor);
746 c; c = gfc_constructor_next (c))
747 formalize_init_expr (c->expr);
748
749 break;
750
751 case EXPR_STRUCTURE:
752 formalize_structure_cons (expr);
753 break;
754
755 default:
756 break;
757 }
758 }
759
760
761 /* Resolve symbol's initial value after all data statement. */
762
763 void
gfc_formalize_init_value(gfc_symbol * sym)764 gfc_formalize_init_value (gfc_symbol *sym)
765 {
766 formalize_init_expr (sym->value);
767 }
768
769
770 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
771 offset. */
772
773 void
gfc_get_section_index(gfc_array_ref * ar,mpz_t * section_index,mpz_t * offset)774 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
775 {
776 int i;
777 mpz_t delta;
778 mpz_t tmp;
779 gfc_expr *start;
780
781 mpz_set_si (*offset, 0);
782 mpz_init (tmp);
783 mpz_init_set_si (delta, 1);
784 for (i = 0; i < ar->dimen; i++)
785 {
786 mpz_init (section_index[i]);
787 switch (ar->dimen_type[i])
788 {
789 case DIMEN_ELEMENT:
790 case DIMEN_RANGE:
791 if (ar->start[i])
792 {
793 start = gfc_copy_expr(ar->start[i]);
794 if(!gfc_simplify_expr(start, 1))
795 gfc_internal_error("Simplification error");
796 mpz_sub (tmp, start->value.integer,
797 ar->as->lower[i]->value.integer);
798 mpz_mul (tmp, tmp, delta);
799 mpz_add (*offset, tmp, *offset);
800 mpz_set (section_index[i], start->value.integer);
801 gfc_free_expr(start);
802 }
803 else
804 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
805 break;
806
807 case DIMEN_VECTOR:
808 gfc_internal_error ("TODO: Vector sections in data statements");
809
810 default:
811 gcc_unreachable ();
812 }
813
814 mpz_sub (tmp, ar->as->upper[i]->value.integer,
815 ar->as->lower[i]->value.integer);
816 mpz_add_ui (tmp, tmp, 1);
817 mpz_mul (delta, tmp, delta);
818 }
819
820 mpz_clear (tmp);
821 mpz_clear (delta);
822 }
823
824