1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2018 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
)
107 HOST_WIDE_INT len
, start
, end
, tlen
;
109 bool alloced_init
= false;
111 gfc_extract_hwi (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_hwi (start_expr
, &start
);
147 gfc_free_expr (start_expr
);
149 gfc_extract_hwi (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
;
170 gfc_warning_now (0, "Unused initialization string at %L because "
171 "variable has zero length", &rvalue
->where
);
176 gfc_warning_now (0, "Initialization string at %L was truncated to "
177 "fit the variable (%ld/%ld)", &rvalue
->where
,
178 (long) tlen
, (long) len
);
183 if (rvalue
->ts
.type
== BT_HOLLERITH
)
185 for (size_t i
= 0; i
< (size_t) len
; i
++)
186 dest
[start
+i
] = rvalue
->representation
.string
[i
];
189 memcpy (&dest
[start
], rvalue
->value
.character
.string
,
190 len
* sizeof (gfc_char_t
));
192 /* Pad with spaces. Substrings will already be blanked. */
193 if (len
< tlen
&& ref
== NULL
)
194 gfc_wide_memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
196 if (rvalue
->ts
.type
== BT_HOLLERITH
)
198 init
->representation
.length
= init
->value
.character
.length
;
199 init
->representation
.string
200 = gfc_widechar_to_char (init
->value
.character
.string
,
201 init
->value
.character
.length
);
208 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
209 LVALUE already has an initialization, we extend this, otherwise we
210 create a new one. If REPEAT is non-NULL, initialize *REPEAT
211 consecutive values in LVALUE the same value in RVALUE. In that case,
212 LVALUE must refer to a full array, not an array section. */
215 gfc_assign_data_value (gfc_expr
*lvalue
, gfc_expr
*rvalue
, mpz_t index
,
220 gfc_expr
*expr
= NULL
;
221 gfc_constructor
*con
;
222 gfc_constructor
*last_con
;
224 gfc_typespec
*last_ts
;
227 symbol
= lvalue
->symtree
->n
.sym
;
228 init
= symbol
->value
;
229 last_ts
= &symbol
->ts
;
231 mpz_init_set_si (offset
, 0);
233 /* Find/create the parent expressions for subobject references. */
234 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
236 /* Break out of the loop if we find a substring. */
237 if (ref
->type
== REF_SUBSTRING
)
239 /* A substring should always be the last subobject reference. */
240 gcc_assert (ref
->next
== NULL
);
244 /* Use the existing initializer expression if it exists. Otherwise
247 expr
= gfc_get_expr ();
251 /* Find or create this element. */
255 if (ref
->u
.ar
.as
->rank
== 0)
257 gcc_assert (ref
->u
.ar
.as
->corank
> 0);
263 if (init
&& expr
->expr_type
!= EXPR_ARRAY
)
265 gfc_error ("%qs at %L already is initialized at %L",
266 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
,
273 /* The element typespec will be the same as the array
276 /* Setup the expression to hold the constructor. */
277 expr
->expr_type
= EXPR_ARRAY
;
278 expr
->rank
= ref
->u
.ar
.as
->rank
;
281 if (ref
->u
.ar
.type
== AR_ELEMENT
)
282 get_array_index (&ref
->u
.ar
, &offset
);
284 mpz_set (offset
, index
);
286 /* Check the bounds. */
287 if (mpz_cmp_si (offset
, 0) < 0)
289 gfc_error ("Data element below array lower bound at %L",
293 else if (repeat
!= NULL
294 && ref
->u
.ar
.type
!= AR_ELEMENT
)
297 gcc_assert (ref
->u
.ar
.type
== AR_FULL
298 && ref
->next
== NULL
);
299 mpz_init_set (end
, offset
);
300 mpz_add (end
, end
, *repeat
);
301 if (spec_size (ref
->u
.ar
.as
, &size
))
303 if (mpz_cmp (end
, size
) > 0)
306 gfc_error ("Data element above array upper bound at %L",
313 con
= gfc_constructor_lookup (expr
->value
.constructor
,
314 mpz_get_si (offset
));
317 con
= gfc_constructor_lookup_next (expr
->value
.constructor
,
318 mpz_get_si (offset
));
319 if (con
!= NULL
&& mpz_cmp (con
->offset
, end
) >= 0)
323 /* Overwriting an existing initializer is non-standard but
324 usually only provokes a warning from other compilers. */
325 if (con
!= NULL
&& con
->expr
!= NULL
)
327 /* Order in which the expressions arrive here depends on
328 whether they are from data statements or F95 style
329 declarations. Therefore, check which is the most
332 exprd
= (LOCATION_LINE (con
->expr
->where
.lb
->location
)
333 > LOCATION_LINE (rvalue
->where
.lb
->location
))
334 ? con
->expr
: rvalue
;
335 if (gfc_notify_std (GFC_STD_GNU
,
336 "re-initialization of %qs at %L",
337 symbol
->name
, &exprd
->where
) == false)
343 gfc_constructor
*next_con
= gfc_constructor_next (con
);
345 if (mpz_cmp (con
->offset
, end
) >= 0)
347 if (mpz_cmp (con
->offset
, offset
) < 0)
349 gcc_assert (mpz_cmp_si (con
->repeat
, 1) > 0);
350 mpz_sub (con
->repeat
, offset
, con
->offset
);
352 else if (mpz_cmp_si (con
->repeat
, 1) > 0
353 && mpz_get_si (con
->offset
)
354 + mpz_get_si (con
->repeat
) > mpz_get_si (end
))
358 = splay_tree_lookup (con
->base
,
359 mpz_get_si (con
->offset
));
361 && con
== (gfc_constructor
*) node
->value
362 && node
->key
== (splay_tree_key
)
363 mpz_get_si (con
->offset
));
364 endi
= mpz_get_si (con
->offset
)
365 + mpz_get_si (con
->repeat
);
366 if (endi
> mpz_get_si (end
) + 1)
367 mpz_set_si (con
->repeat
, endi
- mpz_get_si (end
));
369 mpz_set_si (con
->repeat
, 1);
370 mpz_set (con
->offset
, end
);
371 node
->key
= (splay_tree_key
) mpz_get_si (end
);
375 gfc_constructor_remove (con
);
379 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
380 NULL
, &rvalue
->where
,
381 mpz_get_si (offset
));
382 mpz_set (con
->repeat
, *repeat
);
390 if (spec_size (ref
->u
.ar
.as
, &size
))
392 if (mpz_cmp (offset
, size
) >= 0)
395 gfc_error ("Data element above array upper bound at %L",
403 con
= gfc_constructor_lookup (expr
->value
.constructor
,
404 mpz_get_si (offset
));
407 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
408 NULL
, &rvalue
->where
,
409 mpz_get_si (offset
));
411 else if (mpz_cmp_si (con
->repeat
, 1) > 0)
413 /* Need to split a range. */
414 if (mpz_cmp (con
->offset
, offset
) < 0)
416 gfc_constructor
*pred_con
= con
;
417 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
419 mpz_get_si (offset
));
420 con
->expr
= gfc_copy_expr (pred_con
->expr
);
421 mpz_add (con
->repeat
, pred_con
->offset
, pred_con
->repeat
);
422 mpz_sub (con
->repeat
, con
->repeat
, offset
);
423 mpz_sub (pred_con
->repeat
, offset
, pred_con
->offset
);
425 if (mpz_cmp_si (con
->repeat
, 1) > 0)
427 gfc_constructor
*succ_con
;
429 = gfc_constructor_insert_expr (&expr
->value
.constructor
,
431 mpz_get_si (offset
) + 1);
432 succ_con
->expr
= gfc_copy_expr (con
->expr
);
433 mpz_sub_ui (succ_con
->repeat
, con
->repeat
, 1);
434 mpz_set_si (con
->repeat
, 1);
442 /* Setup the expression to hold the constructor. */
443 expr
->expr_type
= EXPR_STRUCTURE
;
444 expr
->ts
.type
= BT_DERIVED
;
445 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
448 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
449 last_ts
= &ref
->u
.c
.component
->ts
;
451 /* Find the same element in the existing constructor. */
452 con
= find_con_by_component (ref
->u
.c
.component
,
453 expr
->value
.constructor
);
457 /* Create a new constructor. */
458 con
= gfc_constructor_append_expr (&expr
->value
.constructor
,
460 con
->n
.component
= ref
->u
.c
.component
;
470 /* Point the container at the new expression. */
471 if (last_con
== NULL
)
472 symbol
->value
= expr
;
474 last_con
->expr
= expr
;
481 gcc_assert (repeat
== NULL
);
483 if (ref
|| last_ts
->type
== BT_CHARACTER
)
485 /* An initializer has to be constant. */
486 if (rvalue
->expr_type
!= EXPR_CONSTANT
487 || (lvalue
->ts
.u
.cl
->length
== NULL
488 && !(ref
&& ref
->u
.ss
.length
!= NULL
)))
490 expr
= create_character_initializer (init
, last_ts
, ref
, rvalue
);
494 /* Overwriting an existing initializer is non-standard but usually only
495 provokes a warning from other compilers. */
498 /* Order in which the expressions arrive here depends on whether
499 they are from data statements or F95 style declarations.
500 Therefore, check which is the most recent. */
501 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
502 > LOCATION_LINE (rvalue
->where
.lb
->location
))
504 if (gfc_notify_std (GFC_STD_GNU
,
505 "re-initialization of %qs at %L",
506 symbol
->name
, &expr
->where
) == false)
510 expr
= gfc_copy_expr (rvalue
);
511 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
512 gfc_convert_type (expr
, &lvalue
->ts
, 0);
515 if (last_con
== NULL
)
516 symbol
->value
= expr
;
518 last_con
->expr
= expr
;
524 gfc_free_expr (expr
);
530 /* Modify the index of array section and re-calculate the array offset. */
533 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
541 gfc_expr
*start
, *end
, *stride
;
543 for (i
= 0; i
< ar
->dimen
; i
++)
545 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
550 stride
= gfc_copy_expr(ar
->stride
[i
]);
551 if(!gfc_simplify_expr(stride
, 1))
552 gfc_internal_error("Simplification error");
553 mpz_add (section_index
[i
], section_index
[i
],
554 stride
->value
.integer
);
555 if (mpz_cmp_si (stride
->value
.integer
, 0) >= 0)
559 gfc_free_expr(stride
);
563 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
569 end
= gfc_copy_expr(ar
->end
[i
]);
570 if(!gfc_simplify_expr(end
, 1))
571 gfc_internal_error("Simplification error");
572 cmp
= mpz_cmp (section_index
[i
], end
->value
.integer
);
576 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
578 if ((cmp
> 0 && forwards
) || (cmp
< 0 && !forwards
))
580 /* Reset index to start, then loop to advance the next index. */
583 start
= gfc_copy_expr(ar
->start
[i
]);
584 if(!gfc_simplify_expr(start
, 1))
585 gfc_internal_error("Simplification error");
586 mpz_set (section_index
[i
], start
->value
.integer
);
587 gfc_free_expr(start
);
590 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
596 mpz_set_si (*offset_ret
, 0);
597 mpz_init_set_si (delta
, 1);
599 for (i
= 0; i
< ar
->dimen
; i
++)
601 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
602 mpz_mul (tmp
, tmp
, delta
);
603 mpz_add (*offset_ret
, tmp
, *offset_ret
);
605 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
606 ar
->as
->lower
[i
]->value
.integer
);
607 mpz_add_ui (tmp
, tmp
, 1);
608 mpz_mul (delta
, tmp
, delta
);
615 /* Rearrange a structure constructor so the elements are in the specified
616 order. Also insert NULL entries if necessary. */
619 formalize_structure_cons (gfc_expr
*expr
)
621 gfc_constructor_base base
= NULL
;
622 gfc_constructor
*cur
;
623 gfc_component
*order
;
625 /* Constructor is already formalized. */
626 cur
= gfc_constructor_first (expr
->value
.constructor
);
627 if (!cur
|| cur
->n
.component
== NULL
)
630 for (order
= expr
->ts
.u
.derived
->components
; order
; order
= order
->next
)
632 cur
= find_con_by_component (order
, expr
->value
.constructor
);
634 gfc_constructor_append_expr (&base
, cur
->expr
, &cur
->expr
->where
);
636 gfc_constructor_append_expr (&base
, NULL
, NULL
);
639 /* For all what it's worth, one would expect
640 gfc_constructor_free (expr->value.constructor);
641 here. However, if the constructor is actually free'd,
642 hell breaks loose in the testsuite?! */
644 expr
->value
.constructor
= base
;
648 /* Make sure an initialization expression is in normalized form, i.e., all
649 elements of the constructors are in the correct order. */
652 formalize_init_expr (gfc_expr
*expr
)
660 type
= expr
->expr_type
;
664 for (c
= gfc_constructor_first (expr
->value
.constructor
);
665 c
; c
= gfc_constructor_next (c
))
666 formalize_init_expr (c
->expr
);
671 formalize_structure_cons (expr
);
680 /* Resolve symbol's initial value after all data statement. */
683 gfc_formalize_init_value (gfc_symbol
*sym
)
685 formalize_init_expr (sym
->value
);
689 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
693 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
700 mpz_set_si (*offset
, 0);
702 mpz_init_set_si (delta
, 1);
703 for (i
= 0; i
< ar
->dimen
; i
++)
705 mpz_init (section_index
[i
]);
706 switch (ar
->dimen_type
[i
])
712 start
= gfc_copy_expr(ar
->start
[i
]);
713 if(!gfc_simplify_expr(start
, 1))
714 gfc_internal_error("Simplification error");
715 mpz_sub (tmp
, start
->value
.integer
,
716 ar
->as
->lower
[i
]->value
.integer
);
717 mpz_mul (tmp
, tmp
, delta
);
718 mpz_add (*offset
, tmp
, *offset
);
719 mpz_set (section_index
[i
], start
->value
.integer
);
720 gfc_free_expr(start
);
723 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
727 gfc_internal_error ("TODO: Vector sections in data statements");
733 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
734 ar
->as
->lower
[i
]->value
.integer
);
735 mpz_add_ui (tmp
, tmp
, 1);
736 mpz_mul (delta
, tmp
, delta
);