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 | |
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 | 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 | 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 | |
117 | static gfc_constructor * |
118 | find_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 | |
135 | static gfc_expr * |
136 | create_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 | |
262 | bool |
263 | gfc_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 | |
660 | abort: |
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 | |
670 | void |
671 | gfc_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 | |
793 | static void |
794 | formalize_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 | |
826 | static void |
827 | formalize_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 | |
857 | void |
858 | gfc_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 | |
867 | void |
868 | gfc_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 | |