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