1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software
4 Contributed by Lifang Zeng <zlf605@hotmail.com>
6 This file is part of GCC.
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
10 Software Foundation; either version 2, or (at your option) any later
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
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
24 /* Notes for DATA statement implementation:
26 We first assign initial value to each symbol by gfc_assign_data_value
27 during resolveing DATA statement. Refer to check_data_variable and
28 traverse_data_list in resolve.c.
30 The complexity exists in the handling of array section, implied do
31 and array of struct appeared in DATA statement.
33 We call gfc_conv_structure, gfc_con_array_array_initializer,
34 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 (splay_tree spt
, mpz_t offset
)
86 gfc_constructor
*ret
= NULL
;
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 are
92 kept up to date if they are array elements (which is the only time that
93 a specific constructor has to be found). */
95 gcc_assert (spt
!= NULL
);
98 sptn
= splay_tree_lookup (spt
, (splay_tree_key
) mpz_get_si(offset
));
101 ret
= (gfc_constructor
*) sptn
->value
;
104 /* Need to check and see if we match a range, so we will pull
105 the next lowest index and see if the range matches. */
106 sptn
= splay_tree_predecessor (spt
, (splay_tree_key
) mpz_get_si(offset
));
109 con
= (gfc_constructor
*) sptn
->value
;
110 if (mpz_cmp_ui (con
->repeat
, 1) > 0)
113 mpz_add (tmp
, con
->n
.offset
, con
->repeat
);
114 if (mpz_cmp (offset
, tmp
) < 0)
119 ret
= NULL
; /* The range did not match. */
122 ret
= NULL
; /* No pred, so no match. */
129 /* Find if there is a constructor which component is equal to COM. */
131 static gfc_constructor
*
132 find_con_by_component (gfc_component
*com
, gfc_constructor
*con
)
134 for (; con
; con
= con
->next
)
136 if (com
== con
->n
.component
)
143 /* Create a character type initialization expression from RVALUE.
144 TS [and REF] describe [the substring of] the variable being initialized.
145 INIT is thh existing initializer, not NULL. Initialization is performed
146 according to normal assignment rules. */
149 create_character_intializer (gfc_expr
* init
, gfc_typespec
* ts
,
150 gfc_ref
* ref
, gfc_expr
* rvalue
)
157 gfc_extract_int (ts
->cl
->length
, &len
);
161 /* Create a new initializer. */
162 init
= gfc_get_expr ();
163 init
->expr_type
= EXPR_CONSTANT
;
166 dest
= gfc_getmem (len
+ 1);
168 init
->value
.character
.length
= len
;
169 init
->value
.character
.string
= dest
;
170 /* Blank the string if we're only setting a substring. */
172 memset (dest
, ' ', len
);
175 dest
= init
->value
.character
.string
;
179 gfc_expr
*start_expr
, *end_expr
;
181 gcc_assert (ref
->type
== REF_SUBSTRING
);
183 /* Only set a substring of the destination. Fortran substring bounds
184 are one-based [start, end], we want zero based [start, end). */
185 start_expr
= gfc_copy_expr (ref
->u
.ss
.start
);
186 end_expr
= gfc_copy_expr (ref
->u
.ss
.end
);
188 if ((gfc_simplify_expr (start_expr
, 1) == FAILURE
)
189 || (gfc_simplify_expr (end_expr
, 1)) == FAILURE
)
191 gfc_error ("failure to simplify substring reference in DATA"
192 "statement at %L", &ref
->u
.ss
.start
->where
);
196 gfc_extract_int (start_expr
, &start
);
198 gfc_extract_int (end_expr
, &end
);
202 /* Set the whole string. */
207 /* Copy the initial value. */
208 len
= rvalue
->value
.character
.length
;
209 if (len
> end
- start
)
212 gfc_warning_now ("initialization string truncated to match variable "
213 "at %L", &rvalue
->where
);
216 memcpy (&dest
[start
], rvalue
->value
.character
.string
, len
);
218 /* Pad with spaces. Substrings will already be blanked. */
219 if (len
< end
- start
&& ref
== NULL
)
220 memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
222 if (rvalue
->ts
.type
== BT_HOLLERITH
)
228 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
229 LVALUE already has an initialization, we extend this, otherwise we
233 gfc_assign_data_value (gfc_expr
* lvalue
, gfc_expr
* rvalue
, mpz_t index
)
238 gfc_constructor
*con
;
239 gfc_constructor
*last_con
;
240 gfc_constructor
*pred
;
242 gfc_typespec
*last_ts
;
245 splay_tree_node sptn
;
247 symbol
= lvalue
->symtree
->n
.sym
;
248 init
= symbol
->value
;
249 last_ts
= &symbol
->ts
;
251 mpz_init_set_si (offset
, 0);
253 /* Find/create the parent expressions for subobject references. */
254 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
256 /* Break out of the loop if we find a substring. */
257 if (ref
->type
== REF_SUBSTRING
)
259 /* A substring should always be the last subobject reference. */
260 gcc_assert (ref
->next
== NULL
);
264 /* Use the existing initializer expression if it exists. Otherwise
267 expr
= gfc_get_expr ();
271 /* Find or create this element. */
277 /* The element typespec will be the same as the array
280 /* Setup the expression to hold the constructor. */
281 expr
->expr_type
= EXPR_ARRAY
;
282 expr
->rank
= ref
->u
.ar
.as
->rank
;
285 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
287 if (ref
->u
.ar
.type
== AR_ELEMENT
)
288 get_array_index (&ref
->u
.ar
, &offset
);
290 mpz_set (offset
, index
);
292 /* Splay tree containing offset and gfc_constructor. */
293 spt
= expr
->con_by_offset
;
297 spt
= splay_tree_new (splay_tree_compare_ints
,NULL
,NULL
);
298 expr
->con_by_offset
= spt
;
302 con
= find_con_by_offset (spt
, offset
);
306 /* Create a new constructor. */
307 con
= gfc_get_constructor ();
308 mpz_set (con
->n
.offset
, offset
);
309 sptn
= splay_tree_insert (spt
, (splay_tree_key
) mpz_get_si(offset
),
310 (splay_tree_value
) con
);
311 /* Fix up the linked list. */
312 sptn
= splay_tree_predecessor (spt
, (splay_tree_key
) mpz_get_si(offset
));
314 { /* Insert at the head. */
315 con
->next
= expr
->value
.constructor
;
316 expr
->value
.constructor
= con
;
319 { /* Insert in the chain. */
320 pred
= (gfc_constructor
*) sptn
->value
;
321 con
->next
= pred
->next
;
330 /* Setup the expression to hold the constructor. */
331 expr
->expr_type
= EXPR_STRUCTURE
;
332 expr
->ts
.type
= BT_DERIVED
;
333 expr
->ts
.derived
= ref
->u
.c
.sym
;
336 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
337 last_ts
= &ref
->u
.c
.component
->ts
;
339 /* Find the same element in the existing constructor. */
340 con
= expr
->value
.constructor
;
341 con
= find_con_by_component (ref
->u
.c
.component
, con
);
345 /* Create a new constructor. */
346 con
= gfc_get_constructor ();
347 con
->n
.component
= ref
->u
.c
.component
;
348 con
->next
= expr
->value
.constructor
;
349 expr
->value
.constructor
= con
;
359 /* Point the container at the new expression. */
360 if (last_con
== NULL
)
361 symbol
->value
= expr
;
363 last_con
->expr
= expr
;
369 if (ref
|| last_ts
->type
== BT_CHARACTER
)
370 expr
= create_character_intializer (init
, last_ts
, ref
, rvalue
);
373 /* Overwriting an existing initializer is non-standard but usually only
374 provokes a warning from other compilers. */
377 /* Order in which the expressions arrive here depends on whether they
378 are from data statements or F95 style declarations. Therefore,
379 check which is the most recent. */
380 #ifdef USE_MAPPED_LOCATION
381 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
382 > LOCATION_LINE (rvalue
->where
.lb
->location
))
385 expr
= (init
->where
.lb
->linenum
> rvalue
->where
.lb
->linenum
) ?
388 gfc_notify_std (GFC_STD_GNU
, "Extension: re-initialization "
389 "of '%s' at %L", symbol
->name
, &expr
->where
);
392 expr
= gfc_copy_expr (rvalue
);
393 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
394 gfc_convert_type (expr
, &lvalue
->ts
, 0);
397 if (last_con
== NULL
)
398 symbol
->value
= expr
;
400 last_con
->expr
= expr
;
403 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
404 value in RVALUE. For the nonce, LVALUE must refer to a full array, not
408 gfc_assign_data_value_range (gfc_expr
* lvalue
, gfc_expr
* rvalue
,
409 mpz_t index
, mpz_t repeat
)
412 gfc_expr
*init
, *expr
;
413 gfc_constructor
*con
, *last_con
;
414 gfc_constructor
*pred
;
416 gfc_typespec
*last_ts
;
419 splay_tree_node sptn
;
421 symbol
= lvalue
->symtree
->n
.sym
;
422 init
= symbol
->value
;
423 last_ts
= &symbol
->ts
;
425 mpz_init_set_si (offset
, 0);
427 /* Find/create the parent expressions for subobject references. */
428 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
430 /* Use the existing initializer expression if it exists.
431 Otherwise create a new one. */
433 expr
= gfc_get_expr ();
437 /* Find or create this element. */
443 /* The element typespec will be the same as the array
446 /* Setup the expression to hold the constructor. */
447 expr
->expr_type
= EXPR_ARRAY
;
448 expr
->rank
= ref
->u
.ar
.as
->rank
;
451 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
453 if (ref
->u
.ar
.type
== AR_ELEMENT
)
455 get_array_index (&ref
->u
.ar
, &offset
);
457 /* This had better not be the bottom of the reference.
458 We can still get to a full array via a component. */
459 gcc_assert (ref
->next
!= NULL
);
463 mpz_set (offset
, index
);
465 /* We're at a full array or an array section. This means
466 that we've better have found a full array, and that we're
467 at the bottom of the reference. */
468 gcc_assert (ref
->u
.ar
.type
== AR_FULL
);
469 gcc_assert (ref
->next
== NULL
);
472 /* Find the same element in the existing constructor. */
474 /* Splay tree containing offset and gfc_constructor. */
475 spt
= expr
->con_by_offset
;
479 spt
= splay_tree_new (splay_tree_compare_ints
,NULL
,NULL
);
480 expr
->con_by_offset
= spt
;
484 con
= find_con_by_offset (spt
, offset
);
488 /* Create a new constructor. */
489 con
= gfc_get_constructor ();
490 mpz_set (con
->n
.offset
, offset
);
491 if (ref
->next
== NULL
)
492 mpz_set (con
->repeat
, repeat
);
493 sptn
= splay_tree_insert (spt
, (splay_tree_key
) mpz_get_si(offset
),
494 (splay_tree_value
) con
);
495 /* Fix up the linked list. */
496 sptn
= splay_tree_predecessor (spt
, (splay_tree_key
) mpz_get_si(offset
));
498 { /* Insert at the head. */
499 con
->next
= expr
->value
.constructor
;
500 expr
->value
.constructor
= con
;
503 { /* Insert in the chain. */
504 pred
= (gfc_constructor
*) sptn
->value
;
505 con
->next
= pred
->next
;
510 gcc_assert (ref
->next
!= NULL
);
516 /* Setup the expression to hold the constructor. */
517 expr
->expr_type
= EXPR_STRUCTURE
;
518 expr
->ts
.type
= BT_DERIVED
;
519 expr
->ts
.derived
= ref
->u
.c
.sym
;
522 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
523 last_ts
= &ref
->u
.c
.component
->ts
;
525 /* Find the same element in the existing constructor. */
526 con
= expr
->value
.constructor
;
527 con
= find_con_by_component (ref
->u
.c
.component
, con
);
531 /* Create a new constructor. */
532 con
= gfc_get_constructor ();
533 con
->n
.component
= ref
->u
.c
.component
;
534 con
->next
= expr
->value
.constructor
;
535 expr
->value
.constructor
= con
;
538 /* Since we're only intending to initialize arrays here,
539 there better be an inner reference. */
540 gcc_assert (ref
->next
!= NULL
);
550 /* Point the container at the new expression. */
551 if (last_con
== NULL
)
552 symbol
->value
= expr
;
554 last_con
->expr
= expr
;
560 if (last_ts
->type
== BT_CHARACTER
)
561 expr
= create_character_intializer (init
, last_ts
, NULL
, rvalue
);
564 /* We should never be overwriting an existing initializer. */
567 expr
= gfc_copy_expr (rvalue
);
568 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
569 gfc_convert_type (expr
, &lvalue
->ts
, 0);
572 if (last_con
== NULL
)
573 symbol
->value
= expr
;
575 last_con
->expr
= expr
;
578 /* Modify the index of array section and re-calculate the array offset. */
581 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
590 for (i
= 0; i
< ar
->dimen
; i
++)
592 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
597 mpz_add (section_index
[i
], section_index
[i
],
598 ar
->stride
[i
]->value
.integer
);
599 if (mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0) >= 0)
606 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
611 cmp
= mpz_cmp (section_index
[i
], ar
->end
[i
]->value
.integer
);
613 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
615 if ((cmp
> 0 && forwards
)
616 || (cmp
< 0 && ! forwards
))
618 /* Reset index to start, then loop to advance the next index. */
620 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
622 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
628 mpz_set_si (*offset_ret
, 0);
629 mpz_init_set_si (delta
, 1);
631 for (i
= 0; i
< ar
->dimen
; i
++)
633 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
634 mpz_mul (tmp
, tmp
, delta
);
635 mpz_add (*offset_ret
, tmp
, *offset_ret
);
637 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
638 ar
->as
->lower
[i
]->value
.integer
);
639 mpz_add_ui (tmp
, tmp
, 1);
640 mpz_mul (delta
, tmp
, delta
);
647 /* Rearrange a structure constructor so the elements are in the specified
648 order. Also insert NULL entries if necessary. */
651 formalize_structure_cons (gfc_expr
* expr
)
653 gfc_constructor
*head
;
654 gfc_constructor
*tail
;
655 gfc_constructor
*cur
;
656 gfc_constructor
*last
;
658 gfc_component
*order
;
660 c
= expr
->value
.constructor
;
662 /* Constructor is already formalized. */
663 if (c
->n
.component
== NULL
)
667 for (order
= expr
->ts
.derived
->components
; order
; order
= order
->next
)
669 /* Find the next component. */
672 while (cur
!= NULL
&& cur
->n
.component
!= order
)
680 /* Create a new one. */
681 cur
= gfc_get_constructor ();
685 /* Remove it from the chain. */
689 last
->next
= cur
->next
;
692 formalize_init_expr (cur
->expr
);
695 /* Add it to the new constructor. */
704 gcc_assert (c
== NULL
);
705 expr
->value
.constructor
= head
;
709 /* Make sure an initialization expression is in normalized form. Ie. all
710 elements of the constructors are in the correct order. */
713 formalize_init_expr (gfc_expr
* expr
)
721 type
= expr
->expr_type
;
725 c
= expr
->value
.constructor
;
728 formalize_init_expr (c
->expr
);
734 formalize_structure_cons (expr
);
743 /* Resolve symbol's initial value after all data statement. */
746 gfc_formalize_init_value (gfc_symbol
*sym
)
748 formalize_init_expr (sym
->value
);
752 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
756 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
762 mpz_set_si (*offset
, 0);
764 mpz_init_set_si (delta
, 1);
765 for (i
= 0; i
< ar
->dimen
; i
++)
767 mpz_init (section_index
[i
]);
768 switch (ar
->dimen_type
[i
])
774 mpz_sub (tmp
, ar
->start
[i
]->value
.integer
,
775 ar
->as
->lower
[i
]->value
.integer
);
776 mpz_mul (tmp
, tmp
, delta
);
777 mpz_add (*offset
, tmp
, *offset
);
778 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
781 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
785 gfc_internal_error ("TODO: Vector sections in data statements");
791 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
792 ar
->as
->lower
[i
]->value
.integer
);
793 mpz_add_ui (tmp
, tmp
, 1);
794 mpz_mul (delta
, tmp
, delta
);