1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Lifang Zeng <zlf605@hotmail.com>
5 This file is part of GCC.
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
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
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330,Boston, MA
23 /* Notes for DATA statement implementation:
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.
29 The complexity exists in the handleing of array section, implied do
30 and array of struct appeared in DATA statement.
32 We call gfc_conv_structure, gfc_con_array_array_initializer,
33 etc., to convert the initial value. Refer to trans-expr.c and
40 static void formalize_init_expr (gfc_expr *);
42 /* Calculate the array element offset. */
45 get_array_index (gfc_array_ref * ar, mpz_t * offset)
54 mpz_set_si (*offset, 0);
55 mpz_init_set_si (delta, 1);
56 for (i = 0; i < ar->dimen; i++)
58 e = gfc_copy_expr (ar->start[i]);
59 re = gfc_simplify_expr (e, 1);
61 if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
62 || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
63 || (gfc_is_constant_expr (e) == 0))
64 gfc_error ("non-constant array in DATA statement %L.", &ar->where);
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);
70 mpz_sub (tmp, ar->as->upper[i]->value.integer,
71 ar->as->lower[i]->value.integer);
72 mpz_add_ui (tmp, tmp, 1);
73 mpz_mul (delta, tmp, delta);
80 /* Find if there is a constructor which offset is equal to OFFSET. */
82 static gfc_constructor *
83 find_con_by_offset (mpz_t offset, gfc_constructor *con)
85 for (; con; con = con->next)
87 if (mpz_cmp (offset, con->n.offset) == 0)
94 /* Find if there is a constructor which component is equal to COM. */
96 static gfc_constructor *
97 find_con_by_component (gfc_component *com, gfc_constructor *con)
99 for (; con; con = con->next)
101 if (com == con->n.component)
107 /* Assign RVALUE to LVALUE where we assume that LVALUE is a substring
108 reference. We do a little more than that: if LVALUE already has an
109 initialization, we put RVALUE into the existing initialization as
110 per the rules of assignment to a substring. If LVALUE has no
111 initialization yet, we initialize it to all blanks, then filling in
115 assign_substring_data_value (gfc_expr * lvalue, gfc_expr * rvalue)
118 gfc_expr *expr, *init;
124 symbol = lvalue->symtree->n.sym;
126 init = symbol->value;
128 assert (symbol->ts.type == BT_CHARACTER);
129 assert (symbol->ts.cl->length->expr_type == EXPR_CONSTANT);
130 assert (symbol->ts.cl->length->ts.type == BT_INTEGER);
131 assert (symbol->ts.kind == 1);
133 gfc_extract_int (symbol->ts.cl->length, &len);
137 /* Setup the expression to hold the constructor. */
138 expr = gfc_get_expr ();
139 expr->expr_type = EXPR_CONSTANT;
140 expr->ts.type = BT_CHARACTER;
143 expr->value.character.length = len;
144 expr->value.character.string = gfc_getmem (len);
145 memset (expr->value.character.string, ' ', len);
147 symbol->value = expr;
152 /* Now that we have allocated the memory for the string,
153 fill in the initialized places, truncating the
154 intialization string if necessary, i.e.
156 doesn't initialize a(3:3). */
158 gfc_extract_int (ref->u.ss.start, &start);
159 gfc_extract_int (ref->u.ss.end, &end);
164 len = rvalue->value.character.length;
165 c = rvalue->value.character.string;
166 d = &expr->value.character.string[start - 1];
168 for (i = 0; i <= end - start && i < len; i++)
171 /* Pad with spaces. I.e.
173 intializes a(1:2) to 'a ' per the rules for assignment.
174 If init == NULL we don't need to do this, as we have
175 intialized the whole string to blanks above. */
178 for (; i <= end - start; i++)
184 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
185 LVALUE already has an initialization, we extend this, otherwise we
189 gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
194 gfc_constructor *con;
195 gfc_constructor *last_con;
200 if (ref != NULL && ref->type == REF_SUBSTRING)
202 /* No need to go through the for (; ref; ref->next) loop, since
203 a single substring lvalue will only refer to a single
204 substring, and therefore ref->next == NULL. */
205 assert (ref->next == NULL);
206 assign_substring_data_value (lvalue, rvalue);
210 symbol = lvalue->symtree->n.sym;
211 init = symbol->value;
213 mpz_init_set_si (offset, 0);
215 for (; ref; ref = ref->next)
217 /* Use the existing initializer expression if it exists. Otherwise
220 expr = gfc_get_expr ();
224 /* Find or create this element. */
230 /* Setup the expression to hold the constructor. */
231 expr->expr_type = EXPR_ARRAY;
234 assert (ref->next->type == REF_COMPONENT);
235 expr->ts.type = BT_DERIVED;
238 expr->ts = rvalue->ts;
239 expr->rank = ref->u.ar.as->rank;
242 assert (expr->expr_type == EXPR_ARRAY);
244 if (ref->u.ar.type == AR_ELEMENT)
245 get_array_index (&ref->u.ar, &offset);
247 mpz_set (offset, index);
249 /* Find the same element in the existing constructor. */
250 con = expr->value.constructor;
251 con = find_con_by_offset (offset, con);
255 /* Create a new constructor. */
256 con = gfc_get_constructor();
257 mpz_set (con->n.offset, offset);
258 gfc_insert_constructor (expr, con);
265 /* Setup the expression to hold the constructor. */
266 expr->expr_type = EXPR_STRUCTURE;
267 expr->ts.type = BT_DERIVED;
268 expr->ts.derived = ref->u.c.sym;
271 assert (expr->expr_type == EXPR_STRUCTURE);
273 /* Find the same element in the existing constructor. */
274 con = expr->value.constructor;
275 con = find_con_by_component (ref->u.c.component, con);
279 /* Create a new constructor. */
280 con = gfc_get_constructor ();
281 con->n.component = ref->u.c.component;
282 con->next = expr->value.constructor;
283 expr->value.constructor = con;
287 /* case REF_SUBSTRING: dealt with separately above. */
295 /* Point the container at the new expression. */
296 if (last_con == NULL)
297 symbol->value = expr;
299 last_con->expr = expr;
305 expr = gfc_copy_expr (rvalue);
306 if (!gfc_compare_types (&lvalue->ts, &expr->ts))
307 gfc_convert_type (expr, &lvalue->ts, 0);
309 if (last_con == NULL)
310 symbol->value = expr;
313 assert (!last_con->expr);
314 last_con->expr = expr;
319 /* Modify the index of array section and re-calculate the array offset. */
322 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
331 for (i = 0; i < ar->dimen; i++)
333 if (ar->dimen_type[i] != DIMEN_RANGE)
338 mpz_add (section_index[i], section_index[i],
339 ar->stride[i]->value.integer);
340 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
347 mpz_add_ui (section_index[i], section_index[i], 1);
352 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
354 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
356 if ((cmp > 0 && forwards)
357 || (cmp < 0 && ! forwards))
359 /* Reset index to start, then loop to advance the next index. */
361 mpz_set (section_index[i], ar->start[i]->value.integer);
363 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
369 mpz_set_si (*offset_ret, 0);
370 mpz_init_set_si (delta, 1);
372 for (i = 0; i < ar->dimen; i++)
374 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
375 mpz_mul (tmp, tmp, delta);
376 mpz_add (*offset_ret, tmp, *offset_ret);
378 mpz_sub (tmp, ar->as->upper[i]->value.integer,
379 ar->as->lower[i]->value.integer);
380 mpz_add_ui (tmp, tmp, 1);
381 mpz_mul (delta, tmp, delta);
388 /* Rearrange a structure constructor so the elements are in the specified
389 order. Also insert NULL entries if neccessary. */
392 formalize_structure_cons (gfc_expr * expr)
394 gfc_constructor *head;
395 gfc_constructor *tail;
396 gfc_constructor *cur;
397 gfc_constructor *last;
399 gfc_component *order;
401 c = expr->value.constructor;
403 /* Constructor is already fomalized. */
404 if (c->n.component == NULL)
408 for (order = expr->ts.derived->components; order; order = order->next)
410 /* Find the next component. */
413 while (cur != NULL && cur->n.component != order)
421 /* Create a new one. */
422 cur = gfc_get_constructor ();
426 /* Remove it from the chain. */
430 last->next = cur->next;
433 formalize_init_expr (cur->expr);
436 /* Add it to the new constructor. */
446 expr->value.constructor = head;
450 /* Make sure an initialization expression is in normalized form. Ie. all
451 elements of the constructors are in the correct order. */
454 formalize_init_expr (gfc_expr * expr)
462 type = expr->expr_type;
466 c = expr->value.constructor;
469 formalize_init_expr (c->expr);
475 formalize_structure_cons (expr);
484 /* Resolve symbol's initial value after all data statement. */
487 gfc_formalize_init_value (gfc_symbol *sym)
489 formalize_init_expr (sym->value);
493 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
497 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
503 mpz_set_si (*offset, 0);
505 mpz_init_set_si (delta, 1);
506 for (i = 0; i < ar->dimen; i++)
508 mpz_init (section_index[i]);
509 switch (ar->dimen_type[i])
515 mpz_sub (tmp, ar->start[i]->value.integer,
516 ar->as->lower[i]->value.integer);
517 mpz_mul (tmp, tmp, delta);
518 mpz_add (*offset, tmp, *offset);
519 mpz_set (section_index[i], ar->start[i]->value.integer);
522 mpz_set (section_index[i], ar->as->lower[i]->value.integer);
526 gfc_internal_error ("TODO: Vector sections in data statements");
532 mpz_sub (tmp, ar->as->upper[i]->value.integer,
533 ar->as->lower[i]->value.integer);
534 mpz_add_ui (tmp, tmp, 1);
535 mpz_mul (delta, tmp, delta);