]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Supporting functions for resolving DATA statement. |
e7dc5b4f | 2 | Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Lifang Zeng <zlf605@hotmail.com> |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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 2, or (at your option) any later | |
10 | version. | |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 18 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
19 | Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA |
20 | 02110-1301, USA. */ | |
6de9cd9a DN |
21 | |
22 | ||
23 | /* Notes for DATA statement implementation: | |
9fc4d79b | 24 | |
6de9cd9a DN |
25 | We first assign initial value to each symbol by gfc_assign_data_value |
26 | during resolveing DATA statement. Refer to check_data_variable and | |
27 | traverse_data_list in resolve.c. | |
9fc4d79b | 28 | |
e7dc5b4f | 29 | The complexity exists in the handling of array section, implied do |
6de9cd9a | 30 | and array of struct appeared in DATA statement. |
9fc4d79b | 31 | |
6de9cd9a DN |
32 | We call gfc_conv_structure, gfc_con_array_array_initializer, |
33 | etc., to convert the initial value. Refer to trans-expr.c and | |
34 | trans-array.c. */ | |
35 | ||
36 | #include "config.h" | |
6de9cd9a | 37 | #include "gfortran.h" |
6de9cd9a DN |
38 | |
39 | static void formalize_init_expr (gfc_expr *); | |
40 | ||
41 | /* Calculate the array element offset. */ | |
42 | ||
43 | static void | |
44 | get_array_index (gfc_array_ref * ar, mpz_t * offset) | |
45 | { | |
46 | gfc_expr *e; | |
47 | int i; | |
48 | try re; | |
49 | mpz_t delta; | |
50 | mpz_t tmp; | |
51 | ||
52 | mpz_init (tmp); | |
53 | mpz_set_si (*offset, 0); | |
54 | mpz_init_set_si (delta, 1); | |
55 | for (i = 0; i < ar->dimen; i++) | |
56 | { | |
57 | e = gfc_copy_expr (ar->start[i]); | |
58 | re = gfc_simplify_expr (e, 1); | |
59 | ||
60 | if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) | |
61 | || (gfc_is_constant_expr (ar->as->upper[i]) == 0) | |
62 | || (gfc_is_constant_expr (e) == 0)) | |
63 | gfc_error ("non-constant array in DATA statement %L.", &ar->where); | |
64 | mpz_set (tmp, e->value.integer); | |
65 | mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); | |
66 | mpz_mul (tmp, tmp, delta); | |
67 | mpz_add (*offset, tmp, *offset); | |
68 | ||
69 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
70 | ar->as->lower[i]->value.integer); | |
71 | mpz_add_ui (tmp, tmp, 1); | |
72 | mpz_mul (delta, tmp, delta); | |
73 | } | |
74 | mpz_clear (delta); | |
75 | mpz_clear (tmp); | |
76 | } | |
77 | ||
78 | ||
79 | /* Find if there is a constructor which offset is equal to OFFSET. */ | |
80 | ||
81 | static gfc_constructor * | |
82 | find_con_by_offset (mpz_t offset, gfc_constructor *con) | |
83 | { | |
b8502435 RH |
84 | mpz_t tmp; |
85 | gfc_constructor *ret = NULL; | |
86 | ||
87 | mpz_init (tmp); | |
88 | ||
6de9cd9a DN |
89 | for (; con; con = con->next) |
90 | { | |
b8502435 RH |
91 | int cmp = mpz_cmp (offset, con->n.offset); |
92 | ||
93 | /* We retain a sorted list, so if we're too large, we're done. */ | |
94 | if (cmp < 0) | |
95 | break; | |
96 | ||
97 | /* Yaye for exact matches. */ | |
98 | if (cmp == 0) | |
99 | { | |
100 | ret = con; | |
101 | break; | |
102 | } | |
103 | ||
104 | /* If the constructor element is a range, match any element. */ | |
105 | if (mpz_cmp_ui (con->repeat, 1) > 0) | |
106 | { | |
107 | mpz_add (tmp, con->n.offset, con->repeat); | |
108 | if (mpz_cmp (offset, tmp) < 0) | |
109 | { | |
110 | ret = con; | |
111 | break; | |
112 | } | |
113 | } | |
6de9cd9a | 114 | } |
b8502435 RH |
115 | |
116 | mpz_clear (tmp); | |
117 | return ret; | |
6de9cd9a DN |
118 | } |
119 | ||
120 | ||
121 | /* Find if there is a constructor which component is equal to COM. */ | |
122 | ||
123 | static gfc_constructor * | |
124 | find_con_by_component (gfc_component *com, gfc_constructor *con) | |
125 | { | |
126 | for (; con; con = con->next) | |
127 | { | |
128 | if (com == con->n.component) | |
129 | return con; | |
130 | } | |
131 | return NULL; | |
132 | } | |
133 | ||
2fa54841 | 134 | |
aa9c57ec | 135 | /* Create a character type initialization expression from RVALUE. |
ec53454b PB |
136 | TS [and REF] describe [the substring of] the variable being initialized. |
137 | INIT is thh existing initializer, not NULL. Initialization is performed | |
138 | according to normal assignment rules. */ | |
139 | ||
140 | static gfc_expr * | |
141 | create_character_intializer (gfc_expr * init, gfc_typespec * ts, | |
142 | gfc_ref * ref, gfc_expr * rvalue) | |
2fa54841 | 143 | { |
ec53454b PB |
144 | int len; |
145 | int start; | |
146 | int end; | |
147 | char *dest; | |
2fa54841 | 148 | |
ec53454b | 149 | gfc_extract_int (ts->cl->length, &len); |
2fa54841 | 150 | |
2fa54841 TS |
151 | if (init == NULL) |
152 | { | |
ec53454b PB |
153 | /* Create a new initializer. */ |
154 | init = gfc_get_expr (); | |
155 | init->expr_type = EXPR_CONSTANT; | |
156 | init->ts = *ts; | |
157 | ||
158 | dest = gfc_getmem (len); | |
159 | init->value.character.length = len; | |
160 | init->value.character.string = dest; | |
161 | /* Blank the string if we're only setting a substring. */ | |
162 | if (ref != NULL) | |
163 | memset (dest, ' ', len); | |
2fa54841 TS |
164 | } |
165 | else | |
ec53454b | 166 | dest = init->value.character.string; |
2fa54841 | 167 | |
ec53454b PB |
168 | if (ref) |
169 | { | |
6e45f57b | 170 | gcc_assert (ref->type == REF_SUBSTRING); |
2fa54841 | 171 | |
ec53454b PB |
172 | /* Only set a substring of the destination. Fortran substring bounds |
173 | are one-based [start, end], we want zero based [start, end). */ | |
174 | gfc_extract_int (ref->u.ss.start, &start); | |
175 | start--; | |
176 | gfc_extract_int (ref->u.ss.end, &end); | |
177 | } | |
178 | else | |
179 | { | |
180 | /* Set the whole string. */ | |
181 | start = 0; | |
182 | end = len; | |
183 | } | |
2fa54841 | 184 | |
ec53454b PB |
185 | /* Copy the initial value. */ |
186 | len = rvalue->value.character.length; | |
187 | if (len > end - start) | |
188 | len = end - start; | |
189 | memcpy (&dest[start], rvalue->value.character.string, len); | |
2fa54841 | 190 | |
ec53454b PB |
191 | /* Pad with spaces. Substrings will already be blanked. */ |
192 | if (len < end - start && ref == NULL) | |
193 | memset (&dest[start + len], ' ', end - (start + len)); | |
2fa54841 | 194 | |
ec53454b | 195 | return init; |
2fa54841 TS |
196 | } |
197 | ||
198 | /* Assign the initial value RVALUE to LVALUE's symbol->value. If the | |
199 | LVALUE already has an initialization, we extend this, otherwise we | |
200 | create a new one. */ | |
6de9cd9a | 201 | |
6de9cd9a DN |
202 | void |
203 | gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) | |
204 | { | |
205 | gfc_ref *ref; | |
206 | gfc_expr *init; | |
207 | gfc_expr *expr; | |
208 | gfc_constructor *con; | |
209 | gfc_constructor *last_con; | |
210 | gfc_symbol *symbol; | |
ec53454b | 211 | gfc_typespec *last_ts; |
6de9cd9a DN |
212 | mpz_t offset; |
213 | ||
6de9cd9a DN |
214 | symbol = lvalue->symtree->n.sym; |
215 | init = symbol->value; | |
ec53454b | 216 | last_ts = &symbol->ts; |
6de9cd9a DN |
217 | last_con = NULL; |
218 | mpz_init_set_si (offset, 0); | |
219 | ||
ec53454b PB |
220 | /* Find/create the parent expressions for subobject references. */ |
221 | for (ref = lvalue->ref; ref; ref = ref->next) | |
6de9cd9a | 222 | { |
ec53454b PB |
223 | /* Break out of the loop if we find a substring. */ |
224 | if (ref->type == REF_SUBSTRING) | |
225 | { | |
226 | /* A substring should always br the last subobject reference. */ | |
6e45f57b | 227 | gcc_assert (ref->next == NULL); |
ec53454b PB |
228 | break; |
229 | } | |
230 | ||
6de9cd9a DN |
231 | /* Use the existing initializer expression if it exists. Otherwise |
232 | create a new one. */ | |
233 | if (init == NULL) | |
234 | expr = gfc_get_expr (); | |
235 | else | |
236 | expr = init; | |
237 | ||
238 | /* Find or create this element. */ | |
239 | switch (ref->type) | |
240 | { | |
241 | case REF_ARRAY: | |
242 | if (init == NULL) | |
243 | { | |
ec53454b PB |
244 | /* The element typespec will be the same as the array |
245 | typespec. */ | |
246 | expr->ts = *last_ts; | |
6de9cd9a DN |
247 | /* Setup the expression to hold the constructor. */ |
248 | expr->expr_type = EXPR_ARRAY; | |
6de9cd9a DN |
249 | expr->rank = ref->u.ar.as->rank; |
250 | } | |
251 | else | |
6e45f57b | 252 | gcc_assert (expr->expr_type == EXPR_ARRAY); |
6de9cd9a DN |
253 | |
254 | if (ref->u.ar.type == AR_ELEMENT) | |
255 | get_array_index (&ref->u.ar, &offset); | |
256 | else | |
257 | mpz_set (offset, index); | |
258 | ||
259 | /* Find the same element in the existing constructor. */ | |
260 | con = expr->value.constructor; | |
261 | con = find_con_by_offset (offset, con); | |
262 | ||
263 | if (con == NULL) | |
264 | { | |
265 | /* Create a new constructor. */ | |
b8502435 | 266 | con = gfc_get_constructor (); |
6de9cd9a DN |
267 | mpz_set (con->n.offset, offset); |
268 | gfc_insert_constructor (expr, con); | |
269 | } | |
270 | break; | |
271 | ||
272 | case REF_COMPONENT: | |
273 | if (init == NULL) | |
274 | { | |
275 | /* Setup the expression to hold the constructor. */ | |
276 | expr->expr_type = EXPR_STRUCTURE; | |
277 | expr->ts.type = BT_DERIVED; | |
278 | expr->ts.derived = ref->u.c.sym; | |
279 | } | |
280 | else | |
6e45f57b | 281 | gcc_assert (expr->expr_type == EXPR_STRUCTURE); |
ec53454b | 282 | last_ts = &ref->u.c.component->ts; |
6de9cd9a DN |
283 | |
284 | /* Find the same element in the existing constructor. */ | |
285 | con = expr->value.constructor; | |
286 | con = find_con_by_component (ref->u.c.component, con); | |
287 | ||
288 | if (con == NULL) | |
289 | { | |
290 | /* Create a new constructor. */ | |
291 | con = gfc_get_constructor (); | |
292 | con->n.component = ref->u.c.component; | |
293 | con->next = expr->value.constructor; | |
294 | expr->value.constructor = con; | |
295 | } | |
296 | break; | |
297 | ||
6de9cd9a | 298 | default: |
6e45f57b | 299 | gcc_unreachable (); |
6de9cd9a DN |
300 | } |
301 | ||
302 | if (init == NULL) | |
303 | { | |
304 | /* Point the container at the new expression. */ | |
305 | if (last_con == NULL) | |
306 | symbol->value = expr; | |
307 | else | |
308 | last_con->expr = expr; | |
309 | } | |
310 | init = con->expr; | |
311 | last_con = con; | |
312 | } | |
313 | ||
ec53454b PB |
314 | if (ref || last_ts->type == BT_CHARACTER) |
315 | expr = create_character_intializer (init, last_ts, ref, rvalue); | |
316 | else | |
317 | { | |
318 | /* We should never be overwriting an existing initializer. */ | |
6e45f57b | 319 | gcc_assert (!init); |
ec53454b PB |
320 | |
321 | expr = gfc_copy_expr (rvalue); | |
322 | if (!gfc_compare_types (&lvalue->ts, &expr->ts)) | |
323 | gfc_convert_type (expr, &lvalue->ts, 0); | |
ec53454b | 324 | } |
6de9cd9a DN |
325 | |
326 | if (last_con == NULL) | |
327 | symbol->value = expr; | |
328 | else | |
ec53454b | 329 | last_con->expr = expr; |
6de9cd9a DN |
330 | } |
331 | ||
13795658 | 332 | /* Similarly, but initialize REPEAT consecutive values in LVALUE the same |
b8502435 RH |
333 | value in RVALUE. For the nonce, LVALUE must refer to a full array, not |
334 | an array section. */ | |
335 | ||
336 | void | |
337 | gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue, | |
338 | mpz_t index, mpz_t repeat) | |
339 | { | |
340 | gfc_ref *ref; | |
341 | gfc_expr *init, *expr; | |
342 | gfc_constructor *con, *last_con; | |
343 | gfc_symbol *symbol; | |
344 | gfc_typespec *last_ts; | |
345 | mpz_t offset; | |
346 | ||
347 | symbol = lvalue->symtree->n.sym; | |
348 | init = symbol->value; | |
349 | last_ts = &symbol->ts; | |
350 | last_con = NULL; | |
351 | mpz_init_set_si (offset, 0); | |
352 | ||
353 | /* Find/create the parent expressions for subobject references. */ | |
354 | for (ref = lvalue->ref; ref; ref = ref->next) | |
355 | { | |
356 | /* Use the existing initializer expression if it exists. | |
357 | Otherwise create a new one. */ | |
358 | if (init == NULL) | |
359 | expr = gfc_get_expr (); | |
360 | else | |
361 | expr = init; | |
362 | ||
363 | /* Find or create this element. */ | |
364 | switch (ref->type) | |
365 | { | |
366 | case REF_ARRAY: | |
367 | if (init == NULL) | |
368 | { | |
369 | /* The element typespec will be the same as the array | |
370 | typespec. */ | |
371 | expr->ts = *last_ts; | |
372 | /* Setup the expression to hold the constructor. */ | |
373 | expr->expr_type = EXPR_ARRAY; | |
374 | expr->rank = ref->u.ar.as->rank; | |
375 | } | |
376 | else | |
6e45f57b | 377 | gcc_assert (expr->expr_type == EXPR_ARRAY); |
b8502435 RH |
378 | |
379 | if (ref->u.ar.type == AR_ELEMENT) | |
380 | { | |
381 | get_array_index (&ref->u.ar, &offset); | |
382 | ||
383 | /* This had better not be the bottom of the reference. | |
384 | We can still get to a full array via a component. */ | |
6e45f57b | 385 | gcc_assert (ref->next != NULL); |
b8502435 RH |
386 | } |
387 | else | |
388 | { | |
389 | mpz_set (offset, index); | |
390 | ||
391 | /* We're at a full array or an array section. This means | |
392 | that we've better have found a full array, and that we're | |
393 | at the bottom of the reference. */ | |
6e45f57b PB |
394 | gcc_assert (ref->u.ar.type == AR_FULL); |
395 | gcc_assert (ref->next == NULL); | |
b8502435 RH |
396 | } |
397 | ||
398 | /* Find the same element in the existing constructor. */ | |
399 | con = expr->value.constructor; | |
400 | con = find_con_by_offset (offset, con); | |
401 | ||
402 | /* Create a new constructor. */ | |
403 | if (con == NULL) | |
404 | { | |
405 | con = gfc_get_constructor (); | |
406 | mpz_set (con->n.offset, offset); | |
407 | if (ref->next == NULL) | |
408 | mpz_set (con->repeat, repeat); | |
409 | gfc_insert_constructor (expr, con); | |
410 | } | |
411 | else | |
6e45f57b | 412 | gcc_assert (ref->next != NULL); |
b8502435 RH |
413 | break; |
414 | ||
415 | case REF_COMPONENT: | |
416 | if (init == NULL) | |
417 | { | |
418 | /* Setup the expression to hold the constructor. */ | |
419 | expr->expr_type = EXPR_STRUCTURE; | |
420 | expr->ts.type = BT_DERIVED; | |
421 | expr->ts.derived = ref->u.c.sym; | |
422 | } | |
423 | else | |
6e45f57b | 424 | gcc_assert (expr->expr_type == EXPR_STRUCTURE); |
b8502435 RH |
425 | last_ts = &ref->u.c.component->ts; |
426 | ||
427 | /* Find the same element in the existing constructor. */ | |
428 | con = expr->value.constructor; | |
429 | con = find_con_by_component (ref->u.c.component, con); | |
430 | ||
431 | if (con == NULL) | |
432 | { | |
433 | /* Create a new constructor. */ | |
434 | con = gfc_get_constructor (); | |
435 | con->n.component = ref->u.c.component; | |
436 | con->next = expr->value.constructor; | |
437 | expr->value.constructor = con; | |
438 | } | |
439 | ||
440 | /* Since we're only intending to initialize arrays here, | |
441 | there better be an inner reference. */ | |
6e45f57b | 442 | gcc_assert (ref->next != NULL); |
b8502435 RH |
443 | break; |
444 | ||
445 | case REF_SUBSTRING: | |
446 | default: | |
6e45f57b | 447 | gcc_unreachable (); |
b8502435 RH |
448 | } |
449 | ||
450 | if (init == NULL) | |
451 | { | |
452 | /* Point the container at the new expression. */ | |
453 | if (last_con == NULL) | |
454 | symbol->value = expr; | |
455 | else | |
456 | last_con->expr = expr; | |
457 | } | |
458 | init = con->expr; | |
459 | last_con = con; | |
460 | } | |
461 | ||
462 | /* We should never be overwriting an existing initializer. */ | |
6e45f57b | 463 | gcc_assert (!init); |
b8502435 RH |
464 | |
465 | expr = gfc_copy_expr (rvalue); | |
466 | if (!gfc_compare_types (&lvalue->ts, &expr->ts)) | |
467 | gfc_convert_type (expr, &lvalue->ts, 0); | |
468 | ||
469 | if (last_con == NULL) | |
470 | symbol->value = expr; | |
471 | else | |
472 | last_con->expr = expr; | |
473 | } | |
6de9cd9a DN |
474 | |
475 | /* Modify the index of array section and re-calculate the array offset. */ | |
476 | ||
477 | void | |
478 | gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, | |
479 | mpz_t *offset_ret) | |
480 | { | |
481 | int i; | |
482 | mpz_t delta; | |
483 | mpz_t tmp; | |
484 | bool forwards; | |
485 | int cmp; | |
486 | ||
487 | for (i = 0; i < ar->dimen; i++) | |
488 | { | |
489 | if (ar->dimen_type[i] != DIMEN_RANGE) | |
490 | continue; | |
491 | ||
492 | if (ar->stride[i]) | |
493 | { | |
494 | mpz_add (section_index[i], section_index[i], | |
495 | ar->stride[i]->value.integer); | |
496 | if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0) | |
497 | forwards = true; | |
498 | else | |
499 | forwards = false; | |
500 | } | |
501 | else | |
502 | { | |
503 | mpz_add_ui (section_index[i], section_index[i], 1); | |
504 | forwards = true; | |
505 | } | |
506 | ||
507 | if (ar->end[i]) | |
508 | cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer); | |
509 | else | |
510 | cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); | |
511 | ||
512 | if ((cmp > 0 && forwards) | |
513 | || (cmp < 0 && ! forwards)) | |
514 | { | |
515 | /* Reset index to start, then loop to advance the next index. */ | |
516 | if (ar->start[i]) | |
517 | mpz_set (section_index[i], ar->start[i]->value.integer); | |
518 | else | |
519 | mpz_set (section_index[i], ar->as->lower[i]->value.integer); | |
520 | } | |
521 | else | |
522 | break; | |
523 | } | |
524 | ||
525 | mpz_set_si (*offset_ret, 0); | |
526 | mpz_init_set_si (delta, 1); | |
527 | mpz_init (tmp); | |
528 | for (i = 0; i < ar->dimen; i++) | |
529 | { | |
530 | mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); | |
531 | mpz_mul (tmp, tmp, delta); | |
532 | mpz_add (*offset_ret, tmp, *offset_ret); | |
533 | ||
534 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
535 | ar->as->lower[i]->value.integer); | |
536 | mpz_add_ui (tmp, tmp, 1); | |
537 | mpz_mul (delta, tmp, delta); | |
538 | } | |
539 | mpz_clear (tmp); | |
540 | mpz_clear (delta); | |
541 | } | |
542 | ||
543 | ||
544 | /* Rearrange a structure constructor so the elements are in the specified | |
1f2959f0 | 545 | order. Also insert NULL entries if necessary. */ |
6de9cd9a DN |
546 | |
547 | static void | |
548 | formalize_structure_cons (gfc_expr * expr) | |
549 | { | |
550 | gfc_constructor *head; | |
551 | gfc_constructor *tail; | |
552 | gfc_constructor *cur; | |
553 | gfc_constructor *last; | |
554 | gfc_constructor *c; | |
555 | gfc_component *order; | |
556 | ||
557 | c = expr->value.constructor; | |
558 | ||
aa9c57ec | 559 | /* Constructor is already formalized. */ |
6de9cd9a DN |
560 | if (c->n.component == NULL) |
561 | return; | |
562 | ||
563 | head = tail = NULL; | |
564 | for (order = expr->ts.derived->components; order; order = order->next) | |
565 | { | |
566 | /* Find the next component. */ | |
567 | last = NULL; | |
568 | cur = c; | |
569 | while (cur != NULL && cur->n.component != order) | |
570 | { | |
571 | last = cur; | |
572 | cur = cur->next; | |
573 | } | |
574 | ||
575 | if (cur == NULL) | |
576 | { | |
577 | /* Create a new one. */ | |
578 | cur = gfc_get_constructor (); | |
579 | } | |
580 | else | |
581 | { | |
582 | /* Remove it from the chain. */ | |
583 | if (last == NULL) | |
584 | c = cur->next; | |
585 | else | |
586 | last->next = cur->next; | |
587 | cur->next = NULL; | |
588 | ||
589 | formalize_init_expr (cur->expr); | |
590 | } | |
591 | ||
592 | /* Add it to the new constructor. */ | |
593 | if (head == NULL) | |
594 | head = tail = cur; | |
595 | else | |
596 | { | |
597 | tail->next = cur; | |
598 | tail = tail->next; | |
599 | } | |
600 | } | |
6e45f57b | 601 | gcc_assert (c == NULL); |
6de9cd9a DN |
602 | expr->value.constructor = head; |
603 | } | |
604 | ||
605 | ||
606 | /* Make sure an initialization expression is in normalized form. Ie. all | |
607 | elements of the constructors are in the correct order. */ | |
608 | ||
609 | static void | |
610 | formalize_init_expr (gfc_expr * expr) | |
611 | { | |
612 | expr_t type; | |
613 | gfc_constructor *c; | |
614 | ||
615 | if (expr == NULL) | |
616 | return; | |
617 | ||
618 | type = expr->expr_type; | |
619 | switch (type) | |
620 | { | |
621 | case EXPR_ARRAY: | |
622 | c = expr->value.constructor; | |
623 | while (c) | |
624 | { | |
625 | formalize_init_expr (c->expr); | |
626 | c = c->next; | |
627 | } | |
628 | break; | |
629 | ||
630 | case EXPR_STRUCTURE: | |
631 | formalize_structure_cons (expr); | |
632 | break; | |
633 | ||
634 | default: | |
635 | break; | |
636 | } | |
637 | } | |
638 | ||
639 | ||
640 | /* Resolve symbol's initial value after all data statement. */ | |
641 | ||
642 | void | |
643 | gfc_formalize_init_value (gfc_symbol *sym) | |
644 | { | |
645 | formalize_init_expr (sym->value); | |
646 | } | |
647 | ||
648 | ||
649 | /* Get the integer value into RET_AS and SECTION from AS and AR, and return | |
650 | offset. */ | |
651 | ||
652 | void | |
653 | gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) | |
654 | { | |
655 | int i; | |
656 | mpz_t delta; | |
657 | mpz_t tmp; | |
658 | ||
659 | mpz_set_si (*offset, 0); | |
660 | mpz_init (tmp); | |
661 | mpz_init_set_si (delta, 1); | |
662 | for (i = 0; i < ar->dimen; i++) | |
663 | { | |
664 | mpz_init (section_index[i]); | |
665 | switch (ar->dimen_type[i]) | |
666 | { | |
667 | case DIMEN_ELEMENT: | |
668 | case DIMEN_RANGE: | |
669 | if (ar->start[i]) | |
670 | { | |
671 | mpz_sub (tmp, ar->start[i]->value.integer, | |
672 | ar->as->lower[i]->value.integer); | |
673 | mpz_mul (tmp, tmp, delta); | |
674 | mpz_add (*offset, tmp, *offset); | |
675 | mpz_set (section_index[i], ar->start[i]->value.integer); | |
676 | } | |
677 | else | |
678 | mpz_set (section_index[i], ar->as->lower[i]->value.integer); | |
679 | break; | |
680 | ||
681 | case DIMEN_VECTOR: | |
fd528377 | 682 | gfc_internal_error ("TODO: Vector sections in data statements"); |
6de9cd9a DN |
683 | |
684 | default: | |
6e45f57b | 685 | gcc_unreachable (); |
6de9cd9a DN |
686 | } |
687 | ||
688 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
689 | ar->as->lower[i]->value.integer); | |
690 | mpz_add_ui (tmp, tmp, 1); | |
691 | mpz_mul (delta, tmp, delta); | |
692 | } | |
693 | ||
694 | mpz_clear (tmp); | |
695 | mpz_clear (delta); | |
696 | } | |
697 |