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

source code of gcc/fortran/data.cc