1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2013 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 3, 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 COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
22 /* Notes for DATA statement implementation:
24 We first assign initial value to each symbol by gfc_assign_data_value
25 during resolving DATA statement. Refer to check_data_variable and
26 traverse_data_list in resolve.c.
28 The complexity exists in the handling of array section, implied do
29 and array of struct appeared in DATA statement.
31 We call gfc_conv_structure, gfc_con_array_array_initializer,
32 etc., to convert the initial value. Refer to trans-expr.c and
37 #include "coretypes.h"
40 #include "constructor.h"
42 static void formalize_init_expr (gfc_expr
*);
44 /* Calculate the array element offset. */
47 get_array_index (gfc_array_ref
*ar
, mpz_t
*offset
)
55 mpz_set_si (*offset
, 0);
56 mpz_init_set_si (delta
, 1);
57 for (i
= 0; i
< ar
->dimen
; i
++)
59 e
= gfc_copy_expr (ar
->start
[i
]);
60 gfc_simplify_expr (e
, 1);
62 if ((gfc_is_constant_expr (ar
->as
->lower
[i
]) == 0)
63 || (gfc_is_constant_expr (ar
->as
->upper
[i
]) == 0)
64 || (gfc_is_constant_expr (e
) == 0))
65 gfc_error ("non-constant array in DATA statement %L", &ar
->where
);
67 mpz_set (tmp
, e
->value
.integer
);
69 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
70 mpz_mul (tmp
, tmp
, delta
);
71 mpz_add (*offset
, tmp
, *offset
);
73 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
74 ar
->as
->lower
[i
]->value
.integer
);
75 mpz_add_ui (tmp
, tmp
, 1);
76 mpz_mul (delta
, tmp
, delta
);
82 /* Find if there is a constructor which component is equal to COM.
83 TODO: remove this, use symbol.c(gfc_find_component) instead. */
85 static gfc_constructor
*
86 find_con_by_component (gfc_component
*com
, gfc_constructor_base base
)
90 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
91 if (com
== c
->n
.component
)
98 /* Create a character type initialization expression from RVALUE.
99 TS [and REF] describe [the substring of] the variable being initialized.
100 INIT is the existing initializer, not NULL. Initialization is performed
101 according to normal assignment rules. */
104 create_character_initializer (gfc_expr
*init
, gfc_typespec
*ts
,
105 gfc_ref
*ref
, gfc_expr
*rvalue
)
109 bool alloced_init
= false;
111 gfc_extract_int (ts
->u
.cl
->length
, &len
);
115 /* Create a new initializer. */
116 init
= gfc_get_character_expr (ts
->kind
, NULL
, NULL
, len
);
121 dest
= init
->value
.character
.string
;
125 gfc_expr
*start_expr
, *end_expr
;
127 gcc_assert (ref
->type
== REF_SUBSTRING
);
129 /* Only set a substring of the destination. Fortran substring bounds
130 are one-based [start, end], we want zero based [start, end). */
131 start_expr
= gfc_copy_expr (ref
->u
.ss
.start
);
132 end_expr
= gfc_copy_expr (ref
->u
.ss
.end
);
134 if ((!gfc_simplify_expr(start_expr
, 1))
135 || !(gfc_simplify_expr(end_expr
, 1)))
137 gfc_error ("failure to simplify substring reference in DATA "
138 "statement at %L", &ref
->u
.ss
.start
->where
);
139 gfc_free_expr (start_expr
);
140 gfc_free_expr (end_expr
);
142 gfc_free_expr (init
);
146 gfc_extract_int (start_expr
, &start
);
147 gfc_free_expr (start_expr
);
149 gfc_extract_int (end_expr
, &end
);
150 gfc_free_expr (end_expr
);
154 /* Set the whole string. */
159 /* Copy the initial value. */
160 if (rvalue
->ts
.type
== BT_HOLLERITH
)
161 len
= rvalue
->representation
.length
- rvalue
->ts
.u
.pad
;
163 len
= rvalue
->value
.character
.length
;
165 if (len
> end
- start
)
167 gfc_warning_now ("Initialization string starting at %L was "
168 "truncated to fit the variable (%d/%d)",
169 &rvalue
->where
, end
- start
, len
);
173 if (rvalue
->ts
.type
== BT_HOLLERITH
)
176 for (i
= 0; i
< len
; i
++)
177 dest
[start
+i
] = rvalue
->representation
.string
[i
];
180 memcpy (&dest
[start
], rvalue
->value
.character
.string
,
181 len
* sizeof (gfc_char_t
));
183 /* Pad with spaces. Substrings will already be blanked. */
184 if (len
< end
- start
&& ref
== NULL
)
185 gfc_wide_memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
187 if (rvalue
->ts
.type
== BT_HOLLERITH
)
189 init
->representation
.length
= init
->value
.character
.length
;
190 init
->representation
.string
191 = gfc_widechar_to_char (init
->value
.character
.string
,
192 init
->value
.character
.length
);
199 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
200 LVALUE already has an initialization, we extend this, otherwise we
201 create a new one. If REPEAT is non-NULL, initialize *REPEAT
202 consecutive values in LVALUE the same value in RVALUE. In that case,
203 LVALUE must refer to a full array, not an array section. */
206 gfc_assign_data_value (gfc_expr
*lvalue
, gfc_expr
*rvalue
, mpz_t index
,
211 gfc_expr
*expr
= NULL
;
212 gfc_constructor
*con
;
213 gfc_constructor
*last_con
;
215 gfc_typespec
*last_ts
;
218 symbol
= lvalue
->symtree
->n
.sym
;
219 init
= symbol
->value
;
220 last_ts
= &symbol
->ts
;
222 mpz_init_set_si (offset
, 0);
224 /* Find/create the parent expressions for subobject references. */
225 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
227 /* Break out of the loop if we find a substring. */
228 if (ref
->type
== REF_SUBSTRING
)
230 /* A substring should always be the last subobject reference. */
231 gcc_assert (ref
->next
== NULL
);
235 /* Use the existing initializer expression if it exists. Otherwise
238 expr
= gfc_get_expr ();
242 /* Find or create this element. */
246 if (ref
->u
.ar
.as
->rank
== 0)
248 gcc_assert (ref
->u
.ar
.as
->corank
> 0);
254 if (init
&& expr
->expr_type
!= EXPR_ARRAY
)
256 gfc_error ("'%s' at %L already is initialized at %L",
257 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
,
264 /* The element typespec will be the same as the array
267 /* Setup the expression to hold the constructor. */
268 expr
->expr_type
= EXPR_ARRAY
;
269 expr
->rank
= ref
->u
.ar
.as
->rank
;
272 if (ref
->u
.ar
.type
== AR_ELEMENT
)
273 get_array_index (&ref
->u
.ar
, &offset
);
275 mpz_set (offset
, index
);
277 /* Check the bounds. */
278 if (mpz_cmp_si (offset
, 0) < 0)
280 gfc_error ("Data element below array lower bound at %L",
284 else if (repeat
!= NULL
285 && ref
->u
.ar
.type
!= AR_ELEMENT
)
288 gcc_assert (ref
->u
.ar
.type
== AR_FULL
289 && ref
->next
== NULL
);
290 mpz_init_set (end
, offset
);
291 mpz_add (end
, end
, *repeat
);
292 if (spec_size (ref
->u
.ar
.as
, &size
))
294 if (mpz_cmp (end
, size
) > 0)
297 gfc_error ("Data element above array upper bound at %L",
304 con
= gfc_constructor_lookup (expr
->value
.constructor
,
305 mpz_get_si (offset
));
308 con
= gfc_constructor_lookup_next (expr
->value
.constructor
,
309 mpz_get_si (offset
));
310 if (con
!= NULL
&& mpz_cmp (con
->offset
, end
) >= 0)
314 /* Overwriting an existing initializer is non-standard but
315 usually only provokes a warning from other compilers. */
316 if (con
!= NULL
&& con
->expr
!= NULL
)
318 /* Order in which the expressions arrive here depends on
319 whether they are from data statements or F95 style
320 declarations. Therefore, check which is the most
323 exprd
= (LOCATION_LINE (con
->expr
->where
.lb
->location
)
324 > LOCATION_LINE (rvalue
->where
.lb
->location
))
325 ? con
->expr
: rvalue
;
326 if (gfc_notify_std (GFC_STD_GNU
,
327 "re-initialization of '%s' at %L",
328 symbol
->name
, &exprd
->where
) == false)
334 gfc_constructor
*next_con
= gfc_constructor_next (con
);
336 if (mpz_cmp (con
->offset
, end
) >= 0)
338 if (mpz_cmp (con
->offset
, offset
) < 0)
340 gcc_assert (mpz_cmp_si (con
->repeat
, 1) > 0);
341 mpz_sub (con
->repeat
, offset
, con
->offset
);
343 else if (mpz_cmp_si (con
->repeat
, 1) > 0
344 && mpz_get_si (con
->offset
)
345 + mpz_get_si (con
->repeat
) > mpz_get_si (end
))
349 = splay_tree_lookup (con
->base
,
350 mpz_get_si (con
->offset
));
352 && con
== (gfc_constructor
*) node
->value
353 && node
->key
== (splay_tree_key
)
354 mpz_get_si (con
->offset
));
355 endi
= mpz_get_si (con
->offset
)
356 + mpz_get_si (con
->repeat
);
357 if (endi
> mpz_get_si (end
) + 1)
358 mpz_set_si (con
->repeat
, endi
- mpz_get_si (end
));
360 mpz_set_si (con
->repeat
, 1);
361 mpz_set (con
->offset
, end
);
362 node
->key
= (splay_tree_key
) mpz_get_si (end
);
366 gfc_constructor_remove (con
);
370 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
371 NULL
, &rvalue
->where
,
372 mpz_get_si (offset
));
373 mpz_set (con
->repeat
, *repeat
);
381 if (spec_size (ref
->u
.ar
.as
, &size
))
383 if (mpz_cmp (offset
, size
) >= 0)
386 gfc_error ("Data element above array upper bound at %L",
394 con
= gfc_constructor_lookup (expr
->value
.constructor
,
395 mpz_get_si (offset
));
398 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
399 NULL
, &rvalue
->where
,
400 mpz_get_si (offset
));
402 else if (mpz_cmp_si (con
->repeat
, 1) > 0)
404 /* Need to split a range. */
405 if (mpz_cmp (con
->offset
, offset
) < 0)
407 gfc_constructor
*pred_con
= con
;
408 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
410 mpz_get_si (offset
));
411 con
->expr
= gfc_copy_expr (pred_con
->expr
);
412 mpz_add (con
->repeat
, pred_con
->offset
, pred_con
->repeat
);
413 mpz_sub (con
->repeat
, con
->repeat
, offset
);
414 mpz_sub (pred_con
->repeat
, offset
, pred_con
->offset
);
416 if (mpz_cmp_si (con
->repeat
, 1) > 0)
418 gfc_constructor
*succ_con
;
420 = gfc_constructor_insert_expr (&expr
->value
.constructor
,
422 mpz_get_si (offset
) + 1);
423 succ_con
->expr
= gfc_copy_expr (con
->expr
);
424 mpz_sub_ui (succ_con
->repeat
, con
->repeat
, 1);
425 mpz_set_si (con
->repeat
, 1);
433 /* Setup the expression to hold the constructor. */
434 expr
->expr_type
= EXPR_STRUCTURE
;
435 expr
->ts
.type
= BT_DERIVED
;
436 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
439 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
440 last_ts
= &ref
->u
.c
.component
->ts
;
442 /* Find the same element in the existing constructor. */
443 con
= find_con_by_component (ref
->u
.c
.component
,
444 expr
->value
.constructor
);
448 /* Create a new constructor. */
449 con
= gfc_constructor_append_expr (&expr
->value
.constructor
,
451 con
->n
.component
= ref
->u
.c
.component
;
461 /* Point the container at the new expression. */
462 if (last_con
== NULL
)
463 symbol
->value
= expr
;
465 last_con
->expr
= expr
;
472 gcc_assert (repeat
== NULL
);
474 if (ref
|| last_ts
->type
== BT_CHARACTER
)
476 if (lvalue
->ts
.u
.cl
->length
== NULL
&& !(ref
&& ref
->u
.ss
.length
!= NULL
))
478 expr
= create_character_initializer (init
, last_ts
, ref
, rvalue
);
482 /* Overwriting an existing initializer is non-standard but usually only
483 provokes a warning from other compilers. */
486 /* Order in which the expressions arrive here depends on whether
487 they are from data statements or F95 style declarations.
488 Therefore, check which is the most recent. */
489 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
490 > LOCATION_LINE (rvalue
->where
.lb
->location
))
492 if (gfc_notify_std (GFC_STD_GNU
,
493 "re-initialization of '%s' at %L",
494 symbol
->name
, &expr
->where
) == false)
498 expr
= gfc_copy_expr (rvalue
);
499 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
500 gfc_convert_type (expr
, &lvalue
->ts
, 0);
503 if (last_con
== NULL
)
504 symbol
->value
= expr
;
506 last_con
->expr
= expr
;
512 gfc_free_expr (expr
);
518 /* Modify the index of array section and re-calculate the array offset. */
521 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
530 for (i
= 0; i
< ar
->dimen
; i
++)
532 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
537 mpz_add (section_index
[i
], section_index
[i
],
538 ar
->stride
[i
]->value
.integer
);
539 if (mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0) >= 0)
546 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
551 cmp
= mpz_cmp (section_index
[i
], ar
->end
[i
]->value
.integer
);
553 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
555 if ((cmp
> 0 && forwards
) || (cmp
< 0 && !forwards
))
557 /* Reset index to start, then loop to advance the next index. */
559 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
561 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
567 mpz_set_si (*offset_ret
, 0);
568 mpz_init_set_si (delta
, 1);
570 for (i
= 0; i
< ar
->dimen
; i
++)
572 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
573 mpz_mul (tmp
, tmp
, delta
);
574 mpz_add (*offset_ret
, tmp
, *offset_ret
);
576 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
577 ar
->as
->lower
[i
]->value
.integer
);
578 mpz_add_ui (tmp
, tmp
, 1);
579 mpz_mul (delta
, tmp
, delta
);
586 /* Rearrange a structure constructor so the elements are in the specified
587 order. Also insert NULL entries if necessary. */
590 formalize_structure_cons (gfc_expr
*expr
)
592 gfc_constructor_base base
= NULL
;
593 gfc_constructor
*cur
;
594 gfc_component
*order
;
596 /* Constructor is already formalized. */
597 cur
= gfc_constructor_first (expr
->value
.constructor
);
598 if (!cur
|| cur
->n
.component
== NULL
)
601 for (order
= expr
->ts
.u
.derived
->components
; order
; order
= order
->next
)
603 cur
= find_con_by_component (order
, expr
->value
.constructor
);
605 gfc_constructor_append_expr (&base
, cur
->expr
, &cur
->expr
->where
);
607 gfc_constructor_append_expr (&base
, NULL
, NULL
);
610 /* For all what it's worth, one would expect
611 gfc_constructor_free (expr->value.constructor);
612 here. However, if the constructor is actually free'd,
613 hell breaks loose in the testsuite?! */
615 expr
->value
.constructor
= base
;
619 /* Make sure an initialization expression is in normalized form, i.e., all
620 elements of the constructors are in the correct order. */
623 formalize_init_expr (gfc_expr
*expr
)
631 type
= expr
->expr_type
;
635 for (c
= gfc_constructor_first (expr
->value
.constructor
);
636 c
; c
= gfc_constructor_next (c
))
637 formalize_init_expr (c
->expr
);
642 formalize_structure_cons (expr
);
651 /* Resolve symbol's initial value after all data statement. */
654 gfc_formalize_init_value (gfc_symbol
*sym
)
656 formalize_init_expr (sym
->value
);
660 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
664 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
670 mpz_set_si (*offset
, 0);
672 mpz_init_set_si (delta
, 1);
673 for (i
= 0; i
< ar
->dimen
; i
++)
675 mpz_init (section_index
[i
]);
676 switch (ar
->dimen_type
[i
])
682 mpz_sub (tmp
, ar
->start
[i
]->value
.integer
,
683 ar
->as
->lower
[i
]->value
.integer
);
684 mpz_mul (tmp
, tmp
, delta
);
685 mpz_add (*offset
, tmp
, *offset
);
686 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
689 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
693 gfc_internal_error ("TODO: Vector sections in data statements");
699 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
700 ar
->as
->lower
[i
]->value
.integer
);
701 mpz_add_ui (tmp
, tmp
, 1);
702 mpz_mul (delta
, tmp
, delta
);