Branch data Line data Source code
1 : : /* Supporting functions for resolving DATA statement.
2 : : Copyright (C) 2002-2025 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 : 8422 : gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
264 : : mpz_t *repeat)
265 : : {
266 : 8422 : gfc_ref *ref;
267 : 8422 : gfc_expr *init;
268 : 8422 : gfc_expr *expr = NULL;
269 : 8422 : gfc_expr *rexpr;
270 : 8422 : gfc_constructor *con;
271 : 8422 : gfc_constructor *last_con;
272 : 8422 : gfc_symbol *symbol;
273 : 8422 : gfc_typespec *last_ts;
274 : 8422 : mpz_t offset;
275 : :
276 : 8422 : symbol = lvalue->symtree->n.sym;
277 : 8422 : init = symbol->value;
278 : 8422 : last_ts = &symbol->ts;
279 : 8422 : last_con = NULL;
280 : 8422 : mpz_init_set_si (offset, 0);
281 : :
282 : : /* Find/create the parent expressions for subobject references. */
283 : 16088 : for (ref = lvalue->ref; ref; ref = ref->next)
284 : : {
285 : : /* Break out of the loop if we find a substring. */
286 : 7778 : 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 : 7700 : if (init == NULL)
296 : 1123 : expr = gfc_get_expr ();
297 : : else
298 : : expr = init;
299 : :
300 : : /* Find or create this element. */
301 : 7700 : switch (ref->type)
302 : : {
303 : 7186 : case REF_ARRAY:
304 : 7186 : 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 : 7184 : 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 : 961 : expr->ts = *last_ts;
325 : : /* Setup the expression to hold the constructor. */
326 : 961 : expr->expr_type = EXPR_ARRAY;
327 : 961 : expr->rank = ref->u.ar.as->rank;
328 : 961 : expr->corank = ref->u.ar.as->corank;
329 : : }
330 : :
331 : 7177 : 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 : 5761 : mpz_set (offset, index);
338 : :
339 : : /* Check the bounds. */
340 : 7172 : 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 : 7170 : 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 : 7035 : mpz_t size;
444 : 7035 : if (spec_size (ref->u.ar.as, &size))
445 : : {
446 : 7033 : 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 : 7031 : mpz_clear (size);
454 : : }
455 : : }
456 : :
457 : 14066 : con = gfc_constructor_lookup (expr->value.constructor,
458 : 7033 : mpz_get_si (offset));
459 : 7033 : if (!con)
460 : : {
461 : 6649 : con = gfc_constructor_insert_expr (&expr->value.constructor,
462 : : NULL, &rvalue->where,
463 : 6649 : 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 : 7664 : if (init == NULL)
593 : : {
594 : : /* Point the container at the new expression. */
595 : 1112 : if (last_con == NULL)
596 : : {
597 : 906 : symbol->value = expr;
598 : : /* For a new initializer use the location from the
599 : : constructor as fallback. */
600 : 906 : if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL)
601 : 906 : symbol->value->where = con->where;
602 : : }
603 : : else
604 : 206 : last_con->expr = expr;
605 : : }
606 : 7664 : init = con->expr;
607 : 7664 : last_con = con;
608 : : }
609 : :
610 : 8388 : mpz_clear (offset);
611 : 8388 : gcc_assert (repeat == NULL);
612 : :
613 : : /* Overwriting an existing initializer is non-standard but usually only
614 : : provokes a warning from other compilers. */
615 : 8388 : 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 : 8373 : 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 : 7742 : if (lvalue->ts.type == BT_DERIVED
647 : 7742 : && 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 : 7741 : expr = gfc_copy_expr (rvalue);
656 : 7741 : if (!gfc_compare_types (&lvalue->ts, &expr->ts))
657 : 1469 : gfc_convert_type (expr, &lvalue->ts, 0);
658 : : }
659 : :
660 : 8368 : if (IS_POINTER (symbol)
661 : 8368 : && !gfc_check_pointer_assign (lvalue, rvalue, false, true))
662 : : return false;
663 : :
664 : 8367 : if (last_con == NULL)
665 : 1597 : symbol->value = expr;
666 : : else
667 : 6770 : 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 : 363 : gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
683 : : mpz_t *offset_ret, int *vector_offset)
684 : : {
685 : 363 : int i;
686 : 363 : mpz_t delta;
687 : 363 : mpz_t tmp;
688 : 363 : bool forwards;
689 : 363 : int cmp;
690 : 363 : gfc_expr *start, *end, *stride, *elem;
691 : 363 : gfc_constructor_base base;
692 : :
693 : 609 : for (i = 0; i < ar->dimen; i++)
694 : : {
695 : 467 : bool advance = false;
696 : :
697 : 467 : switch (ar->dimen_type[i])
698 : : {
699 : : case DIMEN_ELEMENT:
700 : : /* Loop to advance the next index. */
701 : : advance = true;
702 : : break;
703 : :
704 : 320 : case DIMEN_RANGE:
705 : 320 : if (ar->stride[i])
706 : : {
707 : 120 : stride = gfc_copy_expr(ar->stride[i]);
708 : 120 : if(!gfc_simplify_expr(stride, 1))
709 : 0 : gfc_internal_error("Simplification error");
710 : 120 : mpz_add (section_index[i], section_index[i],
711 : 120 : stride->value.integer);
712 : 120 : if (mpz_cmp_si (stride->value.integer, 0) >= 0)
713 : : forwards = true;
714 : : else
715 : 36 : forwards = false;
716 : 120 : 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 : 320 : if (ar->end[i])
725 : : {
726 : 193 : end = gfc_copy_expr(ar->end[i]);
727 : 193 : if(!gfc_simplify_expr(end, 1))
728 : 0 : gfc_internal_error("Simplification error");
729 : 193 : cmp = mpz_cmp (section_index[i], end->value.integer);
730 : 193 : gfc_free_expr(end);
731 : : }
732 : : else
733 : 127 : cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
734 : :
735 : 320 : if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
736 : : {
737 : : /* Reset index to start, then loop to advance the next index. */
738 : 129 : if (ar->start[i])
739 : : {
740 : 76 : start = gfc_copy_expr(ar->start[i]);
741 : 76 : if(!gfc_simplify_expr(start, 1))
742 : 0 : gfc_internal_error("Simplification error");
743 : 76 : mpz_set (section_index[i], start->value.integer);
744 : 76 : 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 : 363 : mpz_set_si (*offset_ret, 0);
783 : 363 : mpz_init_set_si (delta, 1);
784 : 363 : mpz_init (tmp);
785 : 1247 : for (i = 0; i < ar->dimen; i++)
786 : : {
787 : 521 : mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
788 : 521 : mpz_mul (tmp, tmp, delta);
789 : 521 : mpz_add (*offset_ret, tmp, *offset_ret);
790 : :
791 : 521 : mpz_sub (tmp, ar->as->upper[i]->value.integer,
792 : 521 : ar->as->lower[i]->value.integer);
793 : 521 : mpz_add_ui (tmp, tmp, 1);
794 : 521 : mpz_mul (delta, tmp, delta);
795 : : }
796 : 363 : mpz_clear (tmp);
797 : 363 : mpz_clear (delta);
798 : 363 : }
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 : 42442 : formalize_structure_cons (gfc_expr *expr)
806 : : {
807 : 42442 : gfc_constructor_base base = NULL;
808 : 42442 : gfc_constructor *cur;
809 : 42442 : gfc_component *order;
810 : :
811 : : /* Constructor is already formalized. */
812 : 42442 : cur = gfc_constructor_first (expr->value.constructor);
813 : 42442 : if (!cur || cur->n.component == NULL)
814 : 42301 : 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 : 2004706 : formalize_init_expr (gfc_expr *expr)
839 : : {
840 : 2004706 : expr_t type;
841 : 2004706 : gfc_constructor *c;
842 : :
843 : 2004706 : if (expr == NULL)
844 : : return;
845 : :
846 : 637696 : type = expr->expr_type;
847 : 637696 : switch (type)
848 : : {
849 : 8475 : case EXPR_ARRAY:
850 : 8475 : for (c = gfc_constructor_first (expr->value.constructor);
851 : 242599 : c; c = gfc_constructor_next (c))
852 : 234124 : formalize_init_expr (c->expr);
853 : :
854 : : break;
855 : :
856 : 42442 : case EXPR_STRUCTURE:
857 : 42442 : formalize_structure_cons (expr);
858 : 42442 : break;
859 : :
860 : : default:
861 : : break;
862 : : }
863 : : }
864 : :
865 : :
866 : : /* Resolve symbol's initial value after all data statement. */
867 : :
868 : : void
869 : 1770582 : gfc_formalize_init_value (gfc_symbol *sym)
870 : : {
871 : 1770582 : formalize_init_expr (sym->value);
872 : 1770582 : }
873 : :
874 : :
875 : : /* Get the integer value into RET_AS and SECTION from AS and AR, and return
876 : : offset. */
877 : :
878 : : void
879 : 149 : gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset,
880 : : int *vector_offset)
881 : : {
882 : 149 : int i;
883 : 149 : mpz_t delta;
884 : 149 : mpz_t tmp;
885 : 149 : gfc_expr *start, *elem;
886 : 149 : gfc_constructor_base base;
887 : :
888 : 149 : mpz_set_si (*offset, 0);
889 : 149 : mpz_init (tmp);
890 : 149 : mpz_init_set_si (delta, 1);
891 : 491 : for (i = 0; i < ar->dimen; i++)
892 : : {
893 : 193 : mpz_init (section_index[i]);
894 : 193 : switch (ar->dimen_type[i])
895 : : {
896 : 157 : case DIMEN_ELEMENT:
897 : 157 : case DIMEN_RANGE:
898 : 157 : elem = ar->start[i];
899 : 157 : 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 : 193 : if (elem)
912 : : {
913 : 142 : start = gfc_copy_expr (elem);
914 : 142 : if (!gfc_simplify_expr (start, 1))
915 : 0 : gfc_internal_error ("Simplification error");
916 : 142 : mpz_sub (tmp, start->value.integer,
917 : 142 : ar->as->lower[i]->value.integer);
918 : 142 : mpz_mul (tmp, tmp, delta);
919 : 142 : mpz_add (*offset, tmp, *offset);
920 : 142 : mpz_set (section_index[i], start->value.integer);
921 : 142 : 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 : 193 : mpz_sub (tmp, ar->as->upper[i]->value.integer,
928 : 193 : ar->as->lower[i]->value.integer);
929 : 193 : mpz_add_ui (tmp, tmp, 1);
930 : 193 : mpz_mul (delta, tmp, delta);
931 : : }
932 : :
933 : 149 : mpz_clear (tmp);
934 : 149 : mpz_clear (delta);
935 : 149 : }
936 : :
|
