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