1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* Notes for DATA statement implementation:
25 We first assign initial value to each symbol by gfc_assign_data_value
26 during resolving DATA statement. Refer to check_data_variable and
27 traverse_data_list in resolve.c.
29 The complexity exists in the handling 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
)
53 mpz_set_si (*offset
, 0);
54 mpz_init_set_si (delta
, 1);
55 for (i
= 0; i
< ar
->dimen
; i
++)
57 e
= gfc_copy_expr (ar
->start
[i
]);
58 gfc_simplify_expr (e
, 1);
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
);
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
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). */
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
,
107 (splay_tree_key
) mpz_get_si (offset
));
110 con
= (gfc_constructor
*) sptn
->value
;
111 if (mpz_cmp_ui (con
->repeat
, 1) > 0)
114 mpz_add (tmp
, con
->n
.offset
, con
->repeat
);
115 if (mpz_cmp (offset
, tmp
) < 0)
120 ret
= NULL
; /* The range did not match. */
123 ret
= NULL
; /* No pred, so no match. */
130 /* Find if there is a constructor which component is equal to COM. */
132 static gfc_constructor
*
133 find_con_by_component (gfc_component
*com
, gfc_constructor
*con
)
135 for (; con
; con
= con
->next
)
137 if (com
== con
->n
.component
)
144 /* Create a character type initialization expression from RVALUE.
145 TS [and REF] describe [the substring of] the variable being initialized.
146 INIT is the existing initializer, not NULL. Initialization is performed
147 according to normal assignment rules. */
150 create_character_intializer (gfc_expr
*init
, gfc_typespec
*ts
,
151 gfc_ref
*ref
, gfc_expr
*rvalue
)
156 gfc_extract_int (ts
->u
.cl
->length
, &len
);
160 /* Create a new initializer. */
161 init
= gfc_get_expr ();
162 init
->expr_type
= EXPR_CONSTANT
;
165 dest
= gfc_get_wide_string (len
+ 1);
167 init
->value
.character
.length
= len
;
168 init
->value
.character
.string
= dest
;
169 /* Blank the string if we're only setting a substring. */
171 gfc_wide_memset (dest
, ' ', len
);
174 dest
= init
->value
.character
.string
;
178 gfc_expr
*start_expr
, *end_expr
;
180 gcc_assert (ref
->type
== REF_SUBSTRING
);
182 /* Only set a substring of the destination. Fortran substring bounds
183 are one-based [start, end], we want zero based [start, end). */
184 start_expr
= gfc_copy_expr (ref
->u
.ss
.start
);
185 end_expr
= gfc_copy_expr (ref
->u
.ss
.end
);
187 if ((gfc_simplify_expr (start_expr
, 1) == FAILURE
)
188 || (gfc_simplify_expr (end_expr
, 1)) == FAILURE
)
190 gfc_error ("failure to simplify substring reference in DATA "
191 "statement at %L", &ref
->u
.ss
.start
->where
);
195 gfc_extract_int (start_expr
, &start
);
197 gfc_extract_int (end_expr
, &end
);
201 /* Set the whole string. */
206 /* Copy the initial value. */
207 if (rvalue
->ts
.type
== BT_HOLLERITH
)
208 len
= rvalue
->representation
.length
;
210 len
= rvalue
->value
.character
.length
;
212 if (len
> end
- start
)
215 gfc_warning_now ("initialization string truncated to match variable "
216 "at %L", &rvalue
->where
);
219 if (rvalue
->ts
.type
== BT_HOLLERITH
)
222 for (i
= 0; i
< len
; i
++)
223 dest
[start
+i
] = rvalue
->representation
.string
[i
];
226 memcpy (&dest
[start
], rvalue
->value
.character
.string
,
227 len
* sizeof (gfc_char_t
));
229 /* Pad with spaces. Substrings will already be blanked. */
230 if (len
< end
- start
&& ref
== NULL
)
231 gfc_wide_memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
233 if (rvalue
->ts
.type
== BT_HOLLERITH
)
235 init
->representation
.length
= init
->value
.character
.length
;
236 init
->representation
.string
237 = gfc_widechar_to_char (init
->value
.character
.string
,
238 init
->value
.character
.length
);
245 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
246 LVALUE already has an initialization, we extend this, otherwise we
250 gfc_assign_data_value (gfc_expr
*lvalue
, gfc_expr
*rvalue
, mpz_t index
)
255 gfc_constructor
*con
;
256 gfc_constructor
*last_con
;
257 gfc_constructor
*pred
;
259 gfc_typespec
*last_ts
;
262 splay_tree_node sptn
;
264 symbol
= lvalue
->symtree
->n
.sym
;
265 init
= symbol
->value
;
266 last_ts
= &symbol
->ts
;
268 mpz_init_set_si (offset
, 0);
270 /* Find/create the parent expressions for subobject references. */
271 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
273 /* Break out of the loop if we find a substring. */
274 if (ref
->type
== REF_SUBSTRING
)
276 /* A substring should always be the last subobject reference. */
277 gcc_assert (ref
->next
== NULL
);
281 /* Use the existing initializer expression if it exists. Otherwise
284 expr
= gfc_get_expr ();
288 /* Find or create this element. */
292 if (init
&& expr
->expr_type
!= EXPR_ARRAY
)
294 gfc_error ("'%s' at %L already is initialized at %L",
295 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
,
302 /* The element typespec will be the same as the array
305 /* Setup the expression to hold the constructor. */
306 expr
->expr_type
= EXPR_ARRAY
;
307 expr
->rank
= ref
->u
.ar
.as
->rank
;
310 if (ref
->u
.ar
.type
== AR_ELEMENT
)
311 get_array_index (&ref
->u
.ar
, &offset
);
313 mpz_set (offset
, index
);
315 /* Check the bounds. */
316 if (mpz_cmp_si (offset
, 0) < 0)
318 gfc_error ("Data element below array lower bound at %L",
325 if (spec_size (ref
->u
.ar
.as
, &size
) == SUCCESS
)
327 if (mpz_cmp (offset
, size
) >= 0)
330 gfc_error ("Data element above array upper bound at %L",
338 /* Splay tree containing offset and gfc_constructor. */
339 spt
= expr
->con_by_offset
;
343 spt
= splay_tree_new (splay_tree_compare_ints
, NULL
, NULL
);
344 expr
->con_by_offset
= spt
;
348 con
= find_con_by_offset (spt
, offset
);
354 /* Create a new constructor. */
355 con
= gfc_get_constructor ();
356 mpz_set (con
->n
.offset
, offset
);
357 j
= (splay_tree_key
) mpz_get_si (offset
);
358 sptn
= splay_tree_insert (spt
, j
, (splay_tree_value
) con
);
359 /* Fix up the linked list. */
360 sptn
= splay_tree_predecessor (spt
, j
);
362 { /* Insert at the head. */
363 con
->next
= expr
->value
.constructor
;
364 expr
->value
.constructor
= con
;
367 { /* Insert in the chain. */
368 pred
= (gfc_constructor
*) sptn
->value
;
369 con
->next
= pred
->next
;
378 /* Setup the expression to hold the constructor. */
379 expr
->expr_type
= EXPR_STRUCTURE
;
380 expr
->ts
.type
= BT_DERIVED
;
381 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
384 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
385 last_ts
= &ref
->u
.c
.component
->ts
;
387 /* Find the same element in the existing constructor. */
388 con
= expr
->value
.constructor
;
389 con
= find_con_by_component (ref
->u
.c
.component
, con
);
393 /* Create a new constructor. */
394 con
= gfc_get_constructor ();
395 con
->n
.component
= ref
->u
.c
.component
;
396 con
->next
= expr
->value
.constructor
;
397 expr
->value
.constructor
= con
;
407 /* Point the container at the new expression. */
408 if (last_con
== NULL
)
409 symbol
->value
= expr
;
411 last_con
->expr
= expr
;
417 if (ref
|| last_ts
->type
== BT_CHARACTER
)
419 if (lvalue
->ts
.u
.cl
->length
== NULL
&& !(ref
&& ref
->u
.ss
.length
!= NULL
))
421 expr
= create_character_intializer (init
, last_ts
, ref
, rvalue
);
425 /* Overwriting an existing initializer is non-standard but usually only
426 provokes a warning from other compilers. */
429 /* Order in which the expressions arrive here depends on whether
430 they are from data statements or F95 style declarations.
431 Therefore, check which is the most recent. */
432 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
433 > LOCATION_LINE (rvalue
->where
.lb
->location
))
435 gfc_notify_std (GFC_STD_GNU
, "Extension: re-initialization "
436 "of '%s' at %L", symbol
->name
, &expr
->where
);
439 expr
= gfc_copy_expr (rvalue
);
440 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
441 gfc_convert_type (expr
, &lvalue
->ts
, 0);
444 if (last_con
== NULL
)
445 symbol
->value
= expr
;
447 last_con
->expr
= expr
;
453 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
454 value in RVALUE. For the nonce, LVALUE must refer to a full array, not
458 gfc_assign_data_value_range (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
459 mpz_t index
, mpz_t repeat
)
462 gfc_expr
*init
, *expr
;
463 gfc_constructor
*con
, *last_con
;
464 gfc_constructor
*pred
;
466 gfc_typespec
*last_ts
;
469 splay_tree_node sptn
;
471 symbol
= lvalue
->symtree
->n
.sym
;
472 init
= symbol
->value
;
473 last_ts
= &symbol
->ts
;
475 mpz_init_set_si (offset
, 0);
477 /* Find/create the parent expressions for subobject references. */
478 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
480 /* Use the existing initializer expression if it exists.
481 Otherwise create a new one. */
483 expr
= gfc_get_expr ();
487 /* Find or create this element. */
493 /* The element typespec will be the same as the array
496 /* Setup the expression to hold the constructor. */
497 expr
->expr_type
= EXPR_ARRAY
;
498 expr
->rank
= ref
->u
.ar
.as
->rank
;
501 gcc_assert (expr
->expr_type
== EXPR_ARRAY
);
503 if (ref
->u
.ar
.type
== AR_ELEMENT
)
505 get_array_index (&ref
->u
.ar
, &offset
);
507 /* This had better not be the bottom of the reference.
508 We can still get to a full array via a component. */
509 gcc_assert (ref
->next
!= NULL
);
513 mpz_set (offset
, index
);
515 /* We're at a full array or an array section. This means
516 that we've better have found a full array, and that we're
517 at the bottom of the reference. */
518 gcc_assert (ref
->u
.ar
.type
== AR_FULL
);
519 gcc_assert (ref
->next
== NULL
);
522 /* Find the same element in the existing constructor. */
524 /* Splay tree containing offset and gfc_constructor. */
525 spt
= expr
->con_by_offset
;
529 spt
= splay_tree_new (splay_tree_compare_ints
, NULL
, NULL
);
530 expr
->con_by_offset
= spt
;
534 con
= find_con_by_offset (spt
, offset
);
539 /* Create a new constructor. */
540 con
= gfc_get_constructor ();
541 mpz_set (con
->n
.offset
, offset
);
542 j
= (splay_tree_key
) mpz_get_si (offset
);
544 if (ref
->next
== NULL
)
545 mpz_set (con
->repeat
, repeat
);
546 sptn
= splay_tree_insert (spt
, j
, (splay_tree_value
) con
);
547 /* Fix up the linked list. */
548 sptn
= splay_tree_predecessor (spt
, j
);
550 { /* Insert at the head. */
551 con
->next
= expr
->value
.constructor
;
552 expr
->value
.constructor
= con
;
555 { /* Insert in the chain. */
556 pred
= (gfc_constructor
*) sptn
->value
;
557 con
->next
= pred
->next
;
562 gcc_assert (ref
->next
!= NULL
);
568 /* Setup the expression to hold the constructor. */
569 expr
->expr_type
= EXPR_STRUCTURE
;
570 expr
->ts
.type
= BT_DERIVED
;
571 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
574 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
575 last_ts
= &ref
->u
.c
.component
->ts
;
577 /* Find the same element in the existing constructor. */
578 con
= expr
->value
.constructor
;
579 con
= find_con_by_component (ref
->u
.c
.component
, con
);
583 /* Create a new constructor. */
584 con
= gfc_get_constructor ();
585 con
->n
.component
= ref
->u
.c
.component
;
586 con
->next
= expr
->value
.constructor
;
587 expr
->value
.constructor
= con
;
590 /* Since we're only intending to initialize arrays here,
591 there better be an inner reference. */
592 gcc_assert (ref
->next
!= NULL
);
602 /* Point the container at the new expression. */
603 if (last_con
== NULL
)
604 symbol
->value
= expr
;
606 last_con
->expr
= expr
;
612 if (last_ts
->type
== BT_CHARACTER
)
613 expr
= create_character_intializer (init
, last_ts
, NULL
, rvalue
);
616 /* We should never be overwriting an existing initializer. */
619 expr
= gfc_copy_expr (rvalue
);
620 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
621 gfc_convert_type (expr
, &lvalue
->ts
, 0);
624 if (last_con
== NULL
)
625 symbol
->value
= expr
;
627 last_con
->expr
= expr
;
630 /* Modify the index of array section and re-calculate the array offset. */
633 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
642 for (i
= 0; i
< ar
->dimen
; i
++)
644 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
649 mpz_add (section_index
[i
], section_index
[i
],
650 ar
->stride
[i
]->value
.integer
);
651 if (mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0) >= 0)
658 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
663 cmp
= mpz_cmp (section_index
[i
], ar
->end
[i
]->value
.integer
);
665 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
667 if ((cmp
> 0 && forwards
) || (cmp
< 0 && !forwards
))
669 /* Reset index to start, then loop to advance the next index. */
671 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
673 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
679 mpz_set_si (*offset_ret
, 0);
680 mpz_init_set_si (delta
, 1);
682 for (i
= 0; i
< ar
->dimen
; i
++)
684 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
685 mpz_mul (tmp
, tmp
, delta
);
686 mpz_add (*offset_ret
, tmp
, *offset_ret
);
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
);
698 /* Rearrange a structure constructor so the elements are in the specified
699 order. Also insert NULL entries if necessary. */
702 formalize_structure_cons (gfc_expr
*expr
)
704 gfc_constructor
*head
;
705 gfc_constructor
*tail
;
706 gfc_constructor
*cur
;
707 gfc_constructor
*last
;
709 gfc_component
*order
;
711 c
= expr
->value
.constructor
;
713 /* Constructor is already formalized. */
714 if (!c
|| c
->n
.component
== NULL
)
718 for (order
= expr
->ts
.u
.derived
->components
; order
; order
= order
->next
)
720 /* Find the next component. */
723 while (cur
!= NULL
&& cur
->n
.component
!= order
)
731 /* Create a new one. */
732 cur
= gfc_get_constructor ();
736 /* Remove it from the chain. */
740 last
->next
= cur
->next
;
743 formalize_init_expr (cur
->expr
);
746 /* Add it to the new constructor. */
755 gcc_assert (c
== NULL
);
756 expr
->value
.constructor
= head
;
760 /* Make sure an initialization expression is in normalized form, i.e., all
761 elements of the constructors are in the correct order. */
764 formalize_init_expr (gfc_expr
*expr
)
772 type
= expr
->expr_type
;
776 c
= expr
->value
.constructor
;
779 formalize_init_expr (c
->expr
);
785 formalize_structure_cons (expr
);
794 /* Resolve symbol's initial value after all data statement. */
797 gfc_formalize_init_value (gfc_symbol
*sym
)
799 formalize_init_expr (sym
->value
);
803 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
807 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
813 mpz_set_si (*offset
, 0);
815 mpz_init_set_si (delta
, 1);
816 for (i
= 0; i
< ar
->dimen
; i
++)
818 mpz_init (section_index
[i
]);
819 switch (ar
->dimen_type
[i
])
825 mpz_sub (tmp
, ar
->start
[i
]->value
.integer
,
826 ar
->as
->lower
[i
]->value
.integer
);
827 mpz_mul (tmp
, tmp
, delta
);
828 mpz_add (*offset
, tmp
, *offset
);
829 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
832 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
836 gfc_internal_error ("TODO: Vector sections in data statements");
842 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
843 ar
->as
->lower
[i
]->value
.integer
);
844 mpz_add_ui (tmp
, tmp
, 1);
845 mpz_mul (delta
, tmp
, delta
);