]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Supporting functions for resolving DATA statement. |
c4fae39e | 2 | Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 |
636dff67 | 3 | Free Software Foundation, Inc. |
6de9cd9a DN |
4 | Contributed by Lifang Zeng <zlf605@hotmail.com> |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
21 | |
22 | ||
23 | /* Notes for DATA statement implementation: | |
636dff67 | 24 | |
6de9cd9a | 25 | We first assign initial value to each symbol by gfc_assign_data_value |
df2fba9e | 26 | during resolving DATA statement. Refer to check_data_variable and |
6de9cd9a | 27 | traverse_data_list in resolve.c. |
636dff67 | 28 | |
e7dc5b4f | 29 | The complexity exists in the handling of array section, implied do |
6de9cd9a | 30 | and array of struct appeared in DATA statement. |
636dff67 | 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" |
ca39e6f2 | 38 | #include "data.h" |
6de9cd9a DN |
39 | |
40 | static void formalize_init_expr (gfc_expr *); | |
41 | ||
42 | /* Calculate the array element offset. */ | |
43 | ||
44 | static void | |
636dff67 | 45 | get_array_index (gfc_array_ref *ar, mpz_t *offset) |
6de9cd9a DN |
46 | { |
47 | gfc_expr *e; | |
48 | int i; | |
6de9cd9a DN |
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]); | |
c4fae39e | 58 | gfc_simplify_expr (e, 1); |
6de9cd9a DN |
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)) | |
636dff67 SK |
63 | gfc_error ("non-constant array in DATA statement %L", &ar->where); |
64 | ||
6de9cd9a DN |
65 | mpz_set (tmp, e->value.integer); |
66 | mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); | |
67 | mpz_mul (tmp, tmp, delta); | |
68 | mpz_add (*offset, tmp, *offset); | |
69 | ||
70 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
636dff67 | 71 | ar->as->lower[i]->value.integer); |
6de9cd9a DN |
72 | mpz_add_ui (tmp, tmp, 1); |
73 | mpz_mul (delta, tmp, delta); | |
74 | } | |
75 | mpz_clear (delta); | |
76 | mpz_clear (tmp); | |
77 | } | |
78 | ||
79 | ||
80 | /* Find if there is a constructor which offset is equal to OFFSET. */ | |
81 | ||
82 | static gfc_constructor * | |
5868cbf9 | 83 | find_con_by_offset (splay_tree spt, mpz_t offset) |
6de9cd9a | 84 | { |
b8502435 RH |
85 | mpz_t tmp; |
86 | gfc_constructor *ret = NULL; | |
5868cbf9 BD |
87 | gfc_constructor *con; |
88 | splay_tree_node sptn; | |
b8502435 | 89 | |
636dff67 SK |
90 | /* The complexity is due to needing quick access to the linked list of |
91 | constructors. Both a linked list and a splay tree are used, and both | |
92 | are kept up to date if they are array elements (which is the only time | |
93 | that a specific constructor has to be found). */ | |
b8502435 | 94 | |
5868cbf9 BD |
95 | gcc_assert (spt != NULL); |
96 | mpz_init (tmp); | |
b8502435 | 97 | |
636dff67 | 98 | sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset)); |
b8502435 | 99 | |
5868cbf9 BD |
100 | if (sptn) |
101 | ret = (gfc_constructor*) sptn->value; | |
102 | else | |
103 | { | |
104 | /* Need to check and see if we match a range, so we will pull | |
636dff67 SK |
105 | the next lowest index and see if the range matches. */ |
106 | sptn = splay_tree_predecessor (spt, | |
107 | (splay_tree_key) mpz_get_si (offset)); | |
5868cbf9 | 108 | if (sptn) |
636dff67 SK |
109 | { |
110 | con = (gfc_constructor*) sptn->value; | |
111 | if (mpz_cmp_ui (con->repeat, 1) > 0) | |
112 | { | |
113 | mpz_init (tmp); | |
114 | mpz_add (tmp, con->n.offset, con->repeat); | |
115 | if (mpz_cmp (offset, tmp) < 0) | |
116 | ret = con; | |
117 | mpz_clear (tmp); | |
118 | } | |
119 | else | |
120 | ret = NULL; /* The range did not match. */ | |
121 | } | |
5868cbf9 | 122 | else |
636dff67 | 123 | ret = NULL; /* No pred, so no match. */ |
6de9cd9a | 124 | } |
b8502435 | 125 | |
b8502435 | 126 | return ret; |
6de9cd9a DN |
127 | } |
128 | ||
129 | ||
130 | /* Find if there is a constructor which component is equal to COM. */ | |
131 | ||
132 | static gfc_constructor * | |
133 | find_con_by_component (gfc_component *com, gfc_constructor *con) | |
134 | { | |
135 | for (; con; con = con->next) | |
136 | { | |
137 | if (com == con->n.component) | |
636dff67 | 138 | return con; |
6de9cd9a DN |
139 | } |
140 | return NULL; | |
141 | } | |
142 | ||
2fa54841 | 143 | |
aa9c57ec | 144 | /* Create a character type initialization expression from RVALUE. |
ec53454b | 145 | TS [and REF] describe [the substring of] the variable being initialized. |
df2fba9e | 146 | INIT is the existing initializer, not NULL. Initialization is performed |
ec53454b PB |
147 | according to normal assignment rules. */ |
148 | ||
149 | static gfc_expr * | |
636dff67 SK |
150 | create_character_intializer (gfc_expr *init, gfc_typespec *ts, |
151 | gfc_ref *ref, gfc_expr *rvalue) | |
2fa54841 | 152 | { |
00660189 FXC |
153 | int len, start, end; |
154 | gfc_char_t *dest; | |
2fa54841 | 155 | |
bc21d315 | 156 | gfc_extract_int (ts->u.cl->length, &len); |
2fa54841 | 157 | |
2fa54841 TS |
158 | if (init == NULL) |
159 | { | |
ec53454b PB |
160 | /* Create a new initializer. */ |
161 | init = gfc_get_expr (); | |
162 | init->expr_type = EXPR_CONSTANT; | |
163 | init->ts = *ts; | |
164 | ||
00660189 | 165 | dest = gfc_get_wide_string (len + 1); |
150675a8 | 166 | dest[len] = '\0'; |
ec53454b PB |
167 | init->value.character.length = len; |
168 | init->value.character.string = dest; | |
169 | /* Blank the string if we're only setting a substring. */ | |
170 | if (ref != NULL) | |
00660189 | 171 | gfc_wide_memset (dest, ' ', len); |
2fa54841 TS |
172 | } |
173 | else | |
ec53454b | 174 | dest = init->value.character.string; |
2fa54841 | 175 | |
ec53454b PB |
176 | if (ref) |
177 | { | |
5b440a1c PT |
178 | gfc_expr *start_expr, *end_expr; |
179 | ||
6e45f57b | 180 | gcc_assert (ref->type == REF_SUBSTRING); |
2fa54841 | 181 | |
ec53454b | 182 | /* Only set a substring of the destination. Fortran substring bounds |
636dff67 | 183 | are one-based [start, end], we want zero based [start, end). */ |
5b440a1c PT |
184 | start_expr = gfc_copy_expr (ref->u.ss.start); |
185 | end_expr = gfc_copy_expr (ref->u.ss.end); | |
186 | ||
187 | if ((gfc_simplify_expr (start_expr, 1) == FAILURE) | |
636dff67 | 188 | || (gfc_simplify_expr (end_expr, 1)) == FAILURE) |
5b440a1c | 189 | { |
636dff67 | 190 | gfc_error ("failure to simplify substring reference in DATA " |
5b440a1c PT |
191 | "statement at %L", &ref->u.ss.start->where); |
192 | return NULL; | |
193 | } | |
194 | ||
195 | gfc_extract_int (start_expr, &start); | |
ec53454b | 196 | start--; |
5b440a1c | 197 | gfc_extract_int (end_expr, &end); |
ec53454b PB |
198 | } |
199 | else | |
200 | { | |
201 | /* Set the whole string. */ | |
202 | start = 0; | |
203 | end = len; | |
204 | } | |
2fa54841 | 205 | |
ec53454b | 206 | /* Copy the initial value. */ |
20585ad6 | 207 | if (rvalue->ts.type == BT_HOLLERITH) |
00660189 | 208 | len = rvalue->representation.length; |
20585ad6 | 209 | else |
00660189 | 210 | len = rvalue->value.character.length; |
20585ad6 | 211 | |
ec53454b | 212 | if (len > end - start) |
6690a9e0 PT |
213 | { |
214 | len = end - start; | |
215 | gfc_warning_now ("initialization string truncated to match variable " | |
216 | "at %L", &rvalue->where); | |
217 | } | |
218 | ||
00660189 FXC |
219 | if (rvalue->ts.type == BT_HOLLERITH) |
220 | { | |
221 | int i; | |
222 | for (i = 0; i < len; i++) | |
223 | dest[start+i] = rvalue->representation.string[i]; | |
224 | } | |
225 | else | |
226 | memcpy (&dest[start], rvalue->value.character.string, | |
227 | len * sizeof (gfc_char_t)); | |
2fa54841 | 228 | |
ec53454b PB |
229 | /* Pad with spaces. Substrings will already be blanked. */ |
230 | if (len < end - start && ref == NULL) | |
00660189 | 231 | gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); |
2fa54841 | 232 | |
223f9d5a | 233 | if (rvalue->ts.type == BT_HOLLERITH) |
20585ad6 BM |
234 | { |
235 | init->representation.length = init->value.character.length; | |
00660189 FXC |
236 | init->representation.string |
237 | = gfc_widechar_to_char (init->value.character.string, | |
238 | init->value.character.length); | |
20585ad6 | 239 | } |
223f9d5a | 240 | |
ec53454b | 241 | return init; |
2fa54841 TS |
242 | } |
243 | ||
636dff67 | 244 | |
2fa54841 TS |
245 | /* Assign the initial value RVALUE to LVALUE's symbol->value. If the |
246 | LVALUE already has an initialization, we extend this, otherwise we | |
247 | create a new one. */ | |
6de9cd9a | 248 | |
17b1d2a0 | 249 | gfc_try |
636dff67 | 250 | gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) |
6de9cd9a DN |
251 | { |
252 | gfc_ref *ref; | |
253 | gfc_expr *init; | |
254 | gfc_expr *expr; | |
255 | gfc_constructor *con; | |
256 | gfc_constructor *last_con; | |
5868cbf9 | 257 | gfc_constructor *pred; |
6de9cd9a | 258 | gfc_symbol *symbol; |
ec53454b | 259 | gfc_typespec *last_ts; |
6de9cd9a | 260 | mpz_t offset; |
5868cbf9 BD |
261 | splay_tree spt; |
262 | splay_tree_node sptn; | |
6de9cd9a | 263 | |
6de9cd9a DN |
264 | symbol = lvalue->symtree->n.sym; |
265 | init = symbol->value; | |
ec53454b | 266 | last_ts = &symbol->ts; |
6de9cd9a DN |
267 | last_con = NULL; |
268 | mpz_init_set_si (offset, 0); | |
269 | ||
ec53454b PB |
270 | /* Find/create the parent expressions for subobject references. */ |
271 | for (ref = lvalue->ref; ref; ref = ref->next) | |
6de9cd9a | 272 | { |
ec53454b PB |
273 | /* Break out of the loop if we find a substring. */ |
274 | if (ref->type == REF_SUBSTRING) | |
275 | { | |
6c655c5e | 276 | /* A substring should always be the last subobject reference. */ |
6e45f57b | 277 | gcc_assert (ref->next == NULL); |
ec53454b PB |
278 | break; |
279 | } | |
280 | ||
6de9cd9a | 281 | /* Use the existing initializer expression if it exists. Otherwise |
636dff67 | 282 | create a new one. */ |
6de9cd9a DN |
283 | if (init == NULL) |
284 | expr = gfc_get_expr (); | |
285 | else | |
286 | expr = init; | |
287 | ||
288 | /* Find or create this element. */ | |
289 | switch (ref->type) | |
290 | { | |
291 | case REF_ARRAY: | |
d3a9eea2 TB |
292 | if (ref->u.ar.as->rank == 0) |
293 | { | |
294 | gcc_assert (ref->u.ar.as->corank > 0); | |
295 | if (init == NULL) | |
296 | gfc_free (expr); | |
297 | continue; | |
298 | } | |
299 | ||
d2088bb6 PT |
300 | if (init && expr->expr_type != EXPR_ARRAY) |
301 | { | |
302 | gfc_error ("'%s' at %L already is initialized at %L", | |
303 | lvalue->symtree->n.sym->name, &lvalue->where, | |
304 | &init->where); | |
a24668a3 | 305 | return FAILURE; |
d2088bb6 PT |
306 | } |
307 | ||
6de9cd9a DN |
308 | if (init == NULL) |
309 | { | |
ec53454b PB |
310 | /* The element typespec will be the same as the array |
311 | typespec. */ | |
312 | expr->ts = *last_ts; | |
6de9cd9a DN |
313 | /* Setup the expression to hold the constructor. */ |
314 | expr->expr_type = EXPR_ARRAY; | |
6de9cd9a DN |
315 | expr->rank = ref->u.ar.as->rank; |
316 | } | |
6de9cd9a DN |
317 | |
318 | if (ref->u.ar.type == AR_ELEMENT) | |
319 | get_array_index (&ref->u.ar, &offset); | |
320 | else | |
321 | mpz_set (offset, index); | |
322 | ||
3969f765 PT |
323 | /* Check the bounds. */ |
324 | if (mpz_cmp_si (offset, 0) < 0) | |
325 | { | |
326 | gfc_error ("Data element below array lower bound at %L", | |
327 | &lvalue->where); | |
328 | return FAILURE; | |
329 | } | |
330 | else | |
331 | { | |
332 | mpz_t size; | |
da36ba27 | 333 | if (spec_size (ref->u.ar.as, &size) == SUCCESS) |
3969f765 | 334 | { |
da36ba27 TB |
335 | if (mpz_cmp (offset, size) >= 0) |
336 | { | |
337 | mpz_clear (size); | |
338 | gfc_error ("Data element above array upper bound at %L", | |
339 | &lvalue->where); | |
340 | return FAILURE; | |
341 | } | |
3969f765 | 342 | mpz_clear (size); |
3969f765 | 343 | } |
3969f765 PT |
344 | } |
345 | ||
636dff67 SK |
346 | /* Splay tree containing offset and gfc_constructor. */ |
347 | spt = expr->con_by_offset; | |
5868cbf9 | 348 | |
636dff67 SK |
349 | if (spt == NULL) |
350 | { | |
351 | spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); | |
352 | expr->con_by_offset = spt; | |
353 | con = NULL; | |
354 | } | |
355 | else | |
5868cbf9 | 356 | con = find_con_by_offset (spt, offset); |
6de9cd9a DN |
357 | |
358 | if (con == NULL) | |
359 | { | |
636dff67 SK |
360 | splay_tree_key j; |
361 | ||
6de9cd9a | 362 | /* Create a new constructor. */ |
b8502435 | 363 | con = gfc_get_constructor (); |
6de9cd9a | 364 | mpz_set (con->n.offset, offset); |
636dff67 SK |
365 | j = (splay_tree_key) mpz_get_si (offset); |
366 | sptn = splay_tree_insert (spt, j, (splay_tree_value) con); | |
367 | /* Fix up the linked list. */ | |
368 | sptn = splay_tree_predecessor (spt, j); | |
369 | if (sptn == NULL) | |
370 | { /* Insert at the head. */ | |
371 | con->next = expr->value.constructor; | |
372 | expr->value.constructor = con; | |
373 | } | |
374 | else | |
375 | { /* Insert in the chain. */ | |
376 | pred = (gfc_constructor*) sptn->value; | |
377 | con->next = pred->next; | |
378 | pred->next = con; | |
379 | } | |
6de9cd9a DN |
380 | } |
381 | break; | |
382 | ||
383 | case REF_COMPONENT: | |
384 | if (init == NULL) | |
385 | { | |
386 | /* Setup the expression to hold the constructor. */ | |
387 | expr->expr_type = EXPR_STRUCTURE; | |
388 | expr->ts.type = BT_DERIVED; | |
bc21d315 | 389 | expr->ts.u.derived = ref->u.c.sym; |
6de9cd9a DN |
390 | } |
391 | else | |
6e45f57b | 392 | gcc_assert (expr->expr_type == EXPR_STRUCTURE); |
ec53454b | 393 | last_ts = &ref->u.c.component->ts; |
6de9cd9a DN |
394 | |
395 | /* Find the same element in the existing constructor. */ | |
396 | con = expr->value.constructor; | |
397 | con = find_con_by_component (ref->u.c.component, con); | |
398 | ||
399 | if (con == NULL) | |
400 | { | |
401 | /* Create a new constructor. */ | |
402 | con = gfc_get_constructor (); | |
403 | con->n.component = ref->u.c.component; | |
404 | con->next = expr->value.constructor; | |
405 | expr->value.constructor = con; | |
406 | } | |
407 | break; | |
408 | ||
6de9cd9a | 409 | default: |
6e45f57b | 410 | gcc_unreachable (); |
6de9cd9a DN |
411 | } |
412 | ||
413 | if (init == NULL) | |
414 | { | |
415 | /* Point the container at the new expression. */ | |
416 | if (last_con == NULL) | |
417 | symbol->value = expr; | |
418 | else | |
419 | last_con->expr = expr; | |
420 | } | |
421 | init = con->expr; | |
422 | last_con = con; | |
423 | } | |
424 | ||
ec53454b | 425 | if (ref || last_ts->type == BT_CHARACTER) |
5846213b | 426 | { |
bc21d315 | 427 | if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) |
5846213b SK |
428 | return FAILURE; |
429 | expr = create_character_intializer (init, last_ts, ref, rvalue); | |
430 | } | |
ec53454b PB |
431 | else |
432 | { | |
4075a94e PT |
433 | /* Overwriting an existing initializer is non-standard but usually only |
434 | provokes a warning from other compilers. */ | |
435 | if (init != NULL) | |
436 | { | |
636dff67 SK |
437 | /* Order in which the expressions arrive here depends on whether |
438 | they are from data statements or F95 style declarations. | |
439 | Therefore, check which is the most recent. */ | |
45a82bd9 PB |
440 | expr = (LOCATION_LINE (init->where.lb->location) |
441 | > LOCATION_LINE (rvalue->where.lb->location)) | |
636dff67 | 442 | ? init : rvalue; |
4075a94e | 443 | gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization " |
cd85e27a | 444 | "of '%s' at %L", symbol->name, &expr->where); |
4075a94e | 445 | } |
ec53454b PB |
446 | |
447 | expr = gfc_copy_expr (rvalue); | |
448 | if (!gfc_compare_types (&lvalue->ts, &expr->ts)) | |
449 | gfc_convert_type (expr, &lvalue->ts, 0); | |
ec53454b | 450 | } |
6de9cd9a DN |
451 | |
452 | if (last_con == NULL) | |
453 | symbol->value = expr; | |
454 | else | |
ec53454b | 455 | last_con->expr = expr; |
a24668a3 JD |
456 | |
457 | return SUCCESS; | |
6de9cd9a DN |
458 | } |
459 | ||
636dff67 | 460 | |
13795658 | 461 | /* Similarly, but initialize REPEAT consecutive values in LVALUE the same |
b8502435 RH |
462 | value in RVALUE. For the nonce, LVALUE must refer to a full array, not |
463 | an array section. */ | |
464 | ||
465 | void | |
636dff67 | 466 | gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue, |
b8502435 RH |
467 | mpz_t index, mpz_t repeat) |
468 | { | |
469 | gfc_ref *ref; | |
470 | gfc_expr *init, *expr; | |
471 | gfc_constructor *con, *last_con; | |
5868cbf9 | 472 | gfc_constructor *pred; |
b8502435 RH |
473 | gfc_symbol *symbol; |
474 | gfc_typespec *last_ts; | |
475 | mpz_t offset; | |
5868cbf9 BD |
476 | splay_tree spt; |
477 | splay_tree_node sptn; | |
b8502435 RH |
478 | |
479 | symbol = lvalue->symtree->n.sym; | |
480 | init = symbol->value; | |
481 | last_ts = &symbol->ts; | |
482 | last_con = NULL; | |
483 | mpz_init_set_si (offset, 0); | |
484 | ||
485 | /* Find/create the parent expressions for subobject references. */ | |
486 | for (ref = lvalue->ref; ref; ref = ref->next) | |
487 | { | |
488 | /* Use the existing initializer expression if it exists. | |
489 | Otherwise create a new one. */ | |
490 | if (init == NULL) | |
491 | expr = gfc_get_expr (); | |
492 | else | |
493 | expr = init; | |
494 | ||
495 | /* Find or create this element. */ | |
496 | switch (ref->type) | |
497 | { | |
498 | case REF_ARRAY: | |
499 | if (init == NULL) | |
500 | { | |
501 | /* The element typespec will be the same as the array | |
502 | typespec. */ | |
503 | expr->ts = *last_ts; | |
504 | /* Setup the expression to hold the constructor. */ | |
505 | expr->expr_type = EXPR_ARRAY; | |
506 | expr->rank = ref->u.ar.as->rank; | |
507 | } | |
508 | else | |
6e45f57b | 509 | gcc_assert (expr->expr_type == EXPR_ARRAY); |
b8502435 RH |
510 | |
511 | if (ref->u.ar.type == AR_ELEMENT) | |
512 | { | |
513 | get_array_index (&ref->u.ar, &offset); | |
514 | ||
515 | /* This had better not be the bottom of the reference. | |
516 | We can still get to a full array via a component. */ | |
6e45f57b | 517 | gcc_assert (ref->next != NULL); |
b8502435 RH |
518 | } |
519 | else | |
520 | { | |
521 | mpz_set (offset, index); | |
522 | ||
523 | /* We're at a full array or an array section. This means | |
524 | that we've better have found a full array, and that we're | |
525 | at the bottom of the reference. */ | |
6e45f57b PB |
526 | gcc_assert (ref->u.ar.type == AR_FULL); |
527 | gcc_assert (ref->next == NULL); | |
b8502435 RH |
528 | } |
529 | ||
530 | /* Find the same element in the existing constructor. */ | |
b8502435 | 531 | |
636dff67 SK |
532 | /* Splay tree containing offset and gfc_constructor. */ |
533 | spt = expr->con_by_offset; | |
534 | ||
535 | if (spt == NULL) | |
536 | { | |
537 | spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL); | |
538 | expr->con_by_offset = spt; | |
539 | con = NULL; | |
540 | } | |
541 | else | |
542 | con = find_con_by_offset (spt, offset); | |
543 | ||
544 | if (con == NULL) | |
545 | { | |
546 | splay_tree_key j; | |
547 | /* Create a new constructor. */ | |
548 | con = gfc_get_constructor (); | |
549 | mpz_set (con->n.offset, offset); | |
550 | j = (splay_tree_key) mpz_get_si (offset); | |
551 | ||
552 | if (ref->next == NULL) | |
553 | mpz_set (con->repeat, repeat); | |
554 | sptn = splay_tree_insert (spt, j, (splay_tree_value) con); | |
555 | /* Fix up the linked list. */ | |
556 | sptn = splay_tree_predecessor (spt, j); | |
557 | if (sptn == NULL) | |
558 | { /* Insert at the head. */ | |
559 | con->next = expr->value.constructor; | |
560 | expr->value.constructor = con; | |
561 | } | |
562 | else | |
563 | { /* Insert in the chain. */ | |
564 | pred = (gfc_constructor*) sptn->value; | |
565 | con->next = pred->next; | |
566 | pred->next = con; | |
567 | } | |
568 | } | |
569 | else | |
6e45f57b | 570 | gcc_assert (ref->next != NULL); |
b8502435 RH |
571 | break; |
572 | ||
573 | case REF_COMPONENT: | |
574 | if (init == NULL) | |
575 | { | |
576 | /* Setup the expression to hold the constructor. */ | |
577 | expr->expr_type = EXPR_STRUCTURE; | |
578 | expr->ts.type = BT_DERIVED; | |
bc21d315 | 579 | expr->ts.u.derived = ref->u.c.sym; |
b8502435 RH |
580 | } |
581 | else | |
6e45f57b | 582 | gcc_assert (expr->expr_type == EXPR_STRUCTURE); |
b8502435 RH |
583 | last_ts = &ref->u.c.component->ts; |
584 | ||
585 | /* Find the same element in the existing constructor. */ | |
586 | con = expr->value.constructor; | |
587 | con = find_con_by_component (ref->u.c.component, con); | |
588 | ||
589 | if (con == NULL) | |
590 | { | |
591 | /* Create a new constructor. */ | |
592 | con = gfc_get_constructor (); | |
593 | con->n.component = ref->u.c.component; | |
594 | con->next = expr->value.constructor; | |
595 | expr->value.constructor = con; | |
596 | } | |
597 | ||
598 | /* Since we're only intending to initialize arrays here, | |
599 | there better be an inner reference. */ | |
6e45f57b | 600 | gcc_assert (ref->next != NULL); |
b8502435 RH |
601 | break; |
602 | ||
603 | case REF_SUBSTRING: | |
604 | default: | |
6e45f57b | 605 | gcc_unreachable (); |
b8502435 RH |
606 | } |
607 | ||
608 | if (init == NULL) | |
609 | { | |
610 | /* Point the container at the new expression. */ | |
611 | if (last_con == NULL) | |
612 | symbol->value = expr; | |
613 | else | |
614 | last_con->expr = expr; | |
615 | } | |
616 | init = con->expr; | |
617 | last_con = con; | |
618 | } | |
619 | ||
31f74acc JJ |
620 | if (last_ts->type == BT_CHARACTER) |
621 | expr = create_character_intializer (init, last_ts, NULL, rvalue); | |
622 | else | |
623 | { | |
624 | /* We should never be overwriting an existing initializer. */ | |
625 | gcc_assert (!init); | |
b8502435 | 626 | |
31f74acc JJ |
627 | expr = gfc_copy_expr (rvalue); |
628 | if (!gfc_compare_types (&lvalue->ts, &expr->ts)) | |
629 | gfc_convert_type (expr, &lvalue->ts, 0); | |
630 | } | |
b8502435 RH |
631 | |
632 | if (last_con == NULL) | |
633 | symbol->value = expr; | |
634 | else | |
635 | last_con->expr = expr; | |
636 | } | |
6de9cd9a DN |
637 | |
638 | /* Modify the index of array section and re-calculate the array offset. */ | |
639 | ||
640 | void | |
641 | gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, | |
642 | mpz_t *offset_ret) | |
643 | { | |
644 | int i; | |
645 | mpz_t delta; | |
646 | mpz_t tmp; | |
647 | bool forwards; | |
648 | int cmp; | |
649 | ||
650 | for (i = 0; i < ar->dimen; i++) | |
651 | { | |
652 | if (ar->dimen_type[i] != DIMEN_RANGE) | |
653 | continue; | |
654 | ||
655 | if (ar->stride[i]) | |
656 | { | |
657 | mpz_add (section_index[i], section_index[i], | |
658 | ar->stride[i]->value.integer); | |
659 | if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0) | |
660 | forwards = true; | |
661 | else | |
662 | forwards = false; | |
663 | } | |
664 | else | |
665 | { | |
666 | mpz_add_ui (section_index[i], section_index[i], 1); | |
667 | forwards = true; | |
668 | } | |
669 | ||
670 | if (ar->end[i]) | |
671 | cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer); | |
672 | else | |
673 | cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); | |
674 | ||
636dff67 | 675 | if ((cmp > 0 && forwards) || (cmp < 0 && !forwards)) |
6de9cd9a | 676 | { |
636dff67 | 677 | /* Reset index to start, then loop to advance the next index. */ |
6de9cd9a DN |
678 | if (ar->start[i]) |
679 | mpz_set (section_index[i], ar->start[i]->value.integer); | |
680 | else | |
681 | mpz_set (section_index[i], ar->as->lower[i]->value.integer); | |
682 | } | |
683 | else | |
684 | break; | |
685 | } | |
686 | ||
687 | mpz_set_si (*offset_ret, 0); | |
688 | mpz_init_set_si (delta, 1); | |
689 | mpz_init (tmp); | |
690 | for (i = 0; i < ar->dimen; i++) | |
691 | { | |
692 | mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); | |
693 | mpz_mul (tmp, tmp, delta); | |
694 | mpz_add (*offset_ret, tmp, *offset_ret); | |
695 | ||
696 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
636dff67 | 697 | ar->as->lower[i]->value.integer); |
6de9cd9a DN |
698 | mpz_add_ui (tmp, tmp, 1); |
699 | mpz_mul (delta, tmp, delta); | |
700 | } | |
701 | mpz_clear (tmp); | |
702 | mpz_clear (delta); | |
703 | } | |
704 | ||
705 | ||
706 | /* Rearrange a structure constructor so the elements are in the specified | |
1f2959f0 | 707 | order. Also insert NULL entries if necessary. */ |
6de9cd9a DN |
708 | |
709 | static void | |
636dff67 | 710 | formalize_structure_cons (gfc_expr *expr) |
6de9cd9a DN |
711 | { |
712 | gfc_constructor *head; | |
713 | gfc_constructor *tail; | |
714 | gfc_constructor *cur; | |
715 | gfc_constructor *last; | |
716 | gfc_constructor *c; | |
717 | gfc_component *order; | |
718 | ||
719 | c = expr->value.constructor; | |
720 | ||
aa9c57ec | 721 | /* Constructor is already formalized. */ |
7c8d2703 | 722 | if (!c || c->n.component == NULL) |
6de9cd9a DN |
723 | return; |
724 | ||
725 | head = tail = NULL; | |
bc21d315 | 726 | for (order = expr->ts.u.derived->components; order; order = order->next) |
6de9cd9a DN |
727 | { |
728 | /* Find the next component. */ | |
729 | last = NULL; | |
730 | cur = c; | |
731 | while (cur != NULL && cur->n.component != order) | |
732 | { | |
733 | last = cur; | |
734 | cur = cur->next; | |
735 | } | |
736 | ||
737 | if (cur == NULL) | |
738 | { | |
739 | /* Create a new one. */ | |
740 | cur = gfc_get_constructor (); | |
741 | } | |
742 | else | |
743 | { | |
744 | /* Remove it from the chain. */ | |
745 | if (last == NULL) | |
746 | c = cur->next; | |
747 | else | |
748 | last->next = cur->next; | |
749 | cur->next = NULL; | |
750 | ||
751 | formalize_init_expr (cur->expr); | |
752 | } | |
753 | ||
754 | /* Add it to the new constructor. */ | |
755 | if (head == NULL) | |
756 | head = tail = cur; | |
757 | else | |
758 | { | |
759 | tail->next = cur; | |
760 | tail = tail->next; | |
761 | } | |
762 | } | |
6e45f57b | 763 | gcc_assert (c == NULL); |
6de9cd9a DN |
764 | expr->value.constructor = head; |
765 | } | |
766 | ||
767 | ||
df2fba9e | 768 | /* Make sure an initialization expression is in normalized form, i.e., all |
6de9cd9a DN |
769 | elements of the constructors are in the correct order. */ |
770 | ||
771 | static void | |
636dff67 | 772 | formalize_init_expr (gfc_expr *expr) |
6de9cd9a DN |
773 | { |
774 | expr_t type; | |
775 | gfc_constructor *c; | |
776 | ||
777 | if (expr == NULL) | |
778 | return; | |
779 | ||
780 | type = expr->expr_type; | |
781 | switch (type) | |
782 | { | |
783 | case EXPR_ARRAY: | |
784 | c = expr->value.constructor; | |
785 | while (c) | |
786 | { | |
787 | formalize_init_expr (c->expr); | |
788 | c = c->next; | |
789 | } | |
790 | break; | |
791 | ||
792 | case EXPR_STRUCTURE: | |
793 | formalize_structure_cons (expr); | |
794 | break; | |
795 | ||
796 | default: | |
797 | break; | |
798 | } | |
799 | } | |
800 | ||
801 | ||
802 | /* Resolve symbol's initial value after all data statement. */ | |
803 | ||
804 | void | |
805 | gfc_formalize_init_value (gfc_symbol *sym) | |
806 | { | |
807 | formalize_init_expr (sym->value); | |
808 | } | |
809 | ||
810 | ||
811 | /* Get the integer value into RET_AS and SECTION from AS and AR, and return | |
812 | offset. */ | |
813 | ||
814 | void | |
815 | gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) | |
816 | { | |
817 | int i; | |
818 | mpz_t delta; | |
819 | mpz_t tmp; | |
820 | ||
821 | mpz_set_si (*offset, 0); | |
822 | mpz_init (tmp); | |
823 | mpz_init_set_si (delta, 1); | |
824 | for (i = 0; i < ar->dimen; i++) | |
825 | { | |
826 | mpz_init (section_index[i]); | |
827 | switch (ar->dimen_type[i]) | |
828 | { | |
829 | case DIMEN_ELEMENT: | |
830 | case DIMEN_RANGE: | |
831 | if (ar->start[i]) | |
832 | { | |
833 | mpz_sub (tmp, ar->start[i]->value.integer, | |
834 | ar->as->lower[i]->value.integer); | |
835 | mpz_mul (tmp, tmp, delta); | |
836 | mpz_add (*offset, tmp, *offset); | |
837 | mpz_set (section_index[i], ar->start[i]->value.integer); | |
838 | } | |
839 | else | |
840 | mpz_set (section_index[i], ar->as->lower[i]->value.integer); | |
841 | break; | |
842 | ||
843 | case DIMEN_VECTOR: | |
fd528377 | 844 | gfc_internal_error ("TODO: Vector sections in data statements"); |
6de9cd9a DN |
845 | |
846 | default: | |
6e45f57b | 847 | gcc_unreachable (); |
6de9cd9a DN |
848 | } |
849 | ||
850 | mpz_sub (tmp, ar->as->upper[i]->value.integer, | |
636dff67 | 851 | ar->as->lower[i]->value.integer); |
6de9cd9a DN |
852 | mpz_add_ui (tmp, tmp, 1); |
853 | mpz_mul (delta, tmp, delta); | |
854 | } | |
855 | ||
856 | mpz_clear (tmp); | |
857 | mpz_clear (delta); | |
858 | } | |
859 |