1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2020 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 if (lvalue->ts.u.cl->length
579 && lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT)
580 return false;
581 expr = create_character_initializer (init, last_ts, ref, rvalue);
582 }
583 else
584 {
585 if (lvalue->ts.type == BT_DERIVED
586 && gfc_has_default_initializer (lvalue->ts.u.derived))
587 {
588 gfc_error ("Nonpointer object %qs with default initialization "
589 "shall not appear in a DATA statement at %L",
590 symbol->name, &lvalue->where);
591 return false;
592 }
593
594 expr = gfc_copy_expr (rvalue);
595 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
596 gfc_convert_type (expr, &lvalue->ts, 0);
597 }
598
599 if (last_con == NULL)
600 symbol->value = expr;
601 else
602 last_con->expr = expr;
603
604 return true;
605
606 abort:
607 if (!init)
608 gfc_free_expr (expr);
609 mpz_clear (offset);
610 return false;
611 }
612
613
614 /* Modify the index of array section and re-calculate the array offset. */
615
616 void
gfc_advance_section(mpz_t * section_index,gfc_array_ref * ar,mpz_t * offset_ret)617 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
618 mpz_t *offset_ret)
619 {
620 int i;
621 mpz_t delta;
622 mpz_t tmp;
623 bool forwards;
624 int cmp;
625 gfc_expr *start, *end, *stride;
626
627 for (i = 0; i < ar->dimen; i++)
628 {
629 if (ar->dimen_type[i] != DIMEN_RANGE)
630 continue;
631
632 if (ar->stride[i])
633 {
634 stride = gfc_copy_expr(ar->stride[i]);
635 if(!gfc_simplify_expr(stride, 1))
636 gfc_internal_error("Simplification error");
637 mpz_add (section_index[i], section_index[i],
638 stride->value.integer);
639 if (mpz_cmp_si (stride->value.integer, 0) >= 0)
640 forwards = true;
641 else
642 forwards = false;
643 gfc_free_expr(stride);
644 }
645 else
646 {
647 mpz_add_ui (section_index[i], section_index[i], 1);
648 forwards = true;
649 }
650
651 if (ar->end[i])
652 {
653 end = gfc_copy_expr(ar->end[i]);
654 if(!gfc_simplify_expr(end, 1))
655 gfc_internal_error("Simplification error");
656 cmp = mpz_cmp (section_index[i], end->value.integer);
657 gfc_free_expr(end);
658 }
659 else
660 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
661
662 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
663 {
664 /* Reset index to start, then loop to advance the next index. */
665 if (ar->start[i])
666 {
667 start = gfc_copy_expr(ar->start[i]);
668 if(!gfc_simplify_expr(start, 1))
669 gfc_internal_error("Simplification error");
670 mpz_set (section_index[i], start->value.integer);
671 gfc_free_expr(start);
672 }
673 else
674 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
675 }
676 else
677 break;
678 }
679
680 mpz_set_si (*offset_ret, 0);
681 mpz_init_set_si (delta, 1);
682 mpz_init (tmp);
683 for (i = 0; i < ar->dimen; i++)
684 {
685 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
686 mpz_mul (tmp, tmp, delta);
687 mpz_add (*offset_ret, tmp, *offset_ret);
688
689 mpz_sub (tmp, ar->as->upper[i]->value.integer,
690 ar->as->lower[i]->value.integer);
691 mpz_add_ui (tmp, tmp, 1);
692 mpz_mul (delta, tmp, delta);
693 }
694 mpz_clear (tmp);
695 mpz_clear (delta);
696 }
697
698
699 /* Rearrange a structure constructor so the elements are in the specified
700 order. Also insert NULL entries if necessary. */
701
702 static void
formalize_structure_cons(gfc_expr * expr)703 formalize_structure_cons (gfc_expr *expr)
704 {
705 gfc_constructor_base base = NULL;
706 gfc_constructor *cur;
707 gfc_component *order;
708
709 /* Constructor is already formalized. */
710 cur = gfc_constructor_first (expr->value.constructor);
711 if (!cur || cur->n.component == NULL)
712 return;
713
714 for (order = expr->ts.u.derived->components; order; order = order->next)
715 {
716 cur = find_con_by_component (order, expr->value.constructor);
717 if (cur)
718 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
719 else
720 gfc_constructor_append_expr (&base, NULL, NULL);
721 }
722
723 /* For all what it's worth, one would expect
724 gfc_constructor_free (expr->value.constructor);
725 here. However, if the constructor is actually free'd,
726 hell breaks loose in the testsuite?! */
727
728 expr->value.constructor = base;
729 }
730
731
732 /* Make sure an initialization expression is in normalized form, i.e., all
733 elements of the constructors are in the correct order. */
734
735 static void
formalize_init_expr(gfc_expr * expr)736 formalize_init_expr (gfc_expr *expr)
737 {
738 expr_t type;
739 gfc_constructor *c;
740
741 if (expr == NULL)
742 return;
743
744 type = expr->expr_type;
745 switch (type)
746 {
747 case EXPR_ARRAY:
748 for (c = gfc_constructor_first (expr->value.constructor);
749 c; c = gfc_constructor_next (c))
750 formalize_init_expr (c->expr);
751
752 break;
753
754 case EXPR_STRUCTURE:
755 formalize_structure_cons (expr);
756 break;
757
758 default:
759 break;
760 }
761 }
762
763
764 /* Resolve symbol's initial value after all data statement. */
765
766 void
gfc_formalize_init_value(gfc_symbol * sym)767 gfc_formalize_init_value (gfc_symbol *sym)
768 {
769 formalize_init_expr (sym->value);
770 }
771
772
773 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
774 offset. */
775
776 void
gfc_get_section_index(gfc_array_ref * ar,mpz_t * section_index,mpz_t * offset)777 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
778 {
779 int i;
780 mpz_t delta;
781 mpz_t tmp;
782 gfc_expr *start;
783
784 mpz_set_si (*offset, 0);
785 mpz_init (tmp);
786 mpz_init_set_si (delta, 1);
787 for (i = 0; i < ar->dimen; i++)
788 {
789 mpz_init (section_index[i]);
790 switch (ar->dimen_type[i])
791 {
792 case DIMEN_ELEMENT:
793 case DIMEN_RANGE:
794 if (ar->start[i])
795 {
796 start = gfc_copy_expr(ar->start[i]);
797 if(!gfc_simplify_expr(start, 1))
798 gfc_internal_error("Simplification error");
799 mpz_sub (tmp, start->value.integer,
800 ar->as->lower[i]->value.integer);
801 mpz_mul (tmp, tmp, delta);
802 mpz_add (*offset, tmp, *offset);
803 mpz_set (section_index[i], start->value.integer);
804 gfc_free_expr(start);
805 }
806 else
807 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
808 break;
809
810 case DIMEN_VECTOR:
811 gfc_internal_error ("TODO: Vector sections in data statements");
812
813 default:
814 gcc_unreachable ();
815 }
816
817 mpz_sub (tmp, ar->as->upper[i]->value.integer,
818 ar->as->lower[i]->value.integer);
819 mpz_add_ui (tmp, tmp, 1);
820 mpz_mul (delta, tmp, delta);
821 }
822
823 mpz_clear (tmp);
824 mpz_clear (delta);
825 }
826
827