1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002-2020 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 if (init
&& init
->ts
.type
!= BT_CHARACTER
)
114 gfc_extract_hwi (ts
->u
.cl
->length
, &len
);
118 /* Create a new initializer. */
119 init
= gfc_get_character_expr (ts
->kind
, NULL
, NULL
, len
);
124 dest
= init
->value
.character
.string
;
128 gfc_expr
*start_expr
, *end_expr
;
130 gcc_assert (ref
->type
== REF_SUBSTRING
);
132 /* Only set a substring of the destination. Fortran substring bounds
133 are one-based [start, end], we want zero based [start, end). */
134 start_expr
= gfc_copy_expr (ref
->u
.ss
.start
);
135 end_expr
= gfc_copy_expr (ref
->u
.ss
.end
);
137 if ((!gfc_simplify_expr(start_expr
, 1))
138 || !(gfc_simplify_expr(end_expr
, 1)))
140 gfc_error ("failure to simplify substring reference in DATA "
141 "statement at %L", &ref
->u
.ss
.start
->where
);
142 gfc_free_expr (start_expr
);
143 gfc_free_expr (end_expr
);
145 gfc_free_expr (init
);
149 gfc_extract_hwi (start_expr
, &start
);
150 gfc_free_expr (start_expr
);
152 gfc_extract_hwi (end_expr
, &end
);
153 gfc_free_expr (end_expr
);
157 /* Set the whole string. */
162 /* Copy the initial value. */
163 if (rvalue
->ts
.type
== BT_HOLLERITH
)
164 len
= rvalue
->representation
.length
- rvalue
->ts
.u
.pad
;
166 len
= rvalue
->value
.character
.length
;
173 gfc_warning_now (0, "Unused initialization string at %L because "
174 "variable has zero length", &rvalue
->where
);
179 gfc_warning_now (0, "Initialization string at %L was truncated to "
180 "fit the variable (%ld/%ld)", &rvalue
->where
,
181 (long) tlen
, (long) len
);
186 if (rvalue
->ts
.type
== BT_HOLLERITH
)
188 for (size_t i
= 0; i
< (size_t) len
; i
++)
189 dest
[start
+i
] = rvalue
->representation
.string
[i
];
192 memcpy (&dest
[start
], rvalue
->value
.character
.string
,
193 len
* sizeof (gfc_char_t
));
195 /* Pad with spaces. Substrings will already be blanked. */
196 if (len
< tlen
&& ref
== NULL
)
197 gfc_wide_memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
199 if (rvalue
->ts
.type
== BT_HOLLERITH
)
201 init
->representation
.length
= init
->value
.character
.length
;
202 init
->representation
.string
203 = gfc_widechar_to_char (init
->value
.character
.string
,
204 init
->value
.character
.length
);
211 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
212 LVALUE already has an initialization, we extend this, otherwise we
213 create a new one. If REPEAT is non-NULL, initialize *REPEAT
214 consecutive values in LVALUE the same value in RVALUE. In that case,
215 LVALUE must refer to a full array, not an array section. */
218 gfc_assign_data_value (gfc_expr
*lvalue
, gfc_expr
*rvalue
, mpz_t index
,
223 gfc_expr
*expr
= NULL
;
224 gfc_constructor
*con
;
225 gfc_constructor
*last_con
;
227 gfc_typespec
*last_ts
;
230 symbol
= lvalue
->symtree
->n
.sym
;
231 init
= symbol
->value
;
232 last_ts
= &symbol
->ts
;
234 mpz_init_set_si (offset
, 0);
236 /* Find/create the parent expressions for subobject references. */
237 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
239 /* Break out of the loop if we find a substring. */
240 if (ref
->type
== REF_SUBSTRING
)
242 /* A substring should always be the last subobject reference. */
243 gcc_assert (ref
->next
== NULL
);
247 /* Use the existing initializer expression if it exists. Otherwise
250 expr
= gfc_get_expr ();
254 /* Find or create this element. */
258 if (ref
->u
.ar
.as
->rank
== 0)
260 gcc_assert (ref
->u
.ar
.as
->corank
> 0);
266 if (init
&& expr
->expr_type
!= EXPR_ARRAY
)
268 gfc_error ("%qs at %L already is initialized at %L",
269 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
,
276 /* The element typespec will be the same as the array
279 /* Setup the expression to hold the constructor. */
280 expr
->expr_type
= EXPR_ARRAY
;
281 expr
->rank
= ref
->u
.ar
.as
->rank
;
284 if (ref
->u
.ar
.type
== AR_ELEMENT
)
285 get_array_index (&ref
->u
.ar
, &offset
);
287 mpz_set (offset
, index
);
289 /* Check the bounds. */
290 if (mpz_cmp_si (offset
, 0) < 0)
292 gfc_error ("Data element below array lower bound at %L",
296 else if (repeat
!= NULL
297 && ref
->u
.ar
.type
!= AR_ELEMENT
)
300 gcc_assert (ref
->u
.ar
.type
== AR_FULL
301 && ref
->next
== NULL
);
302 mpz_init_set (end
, offset
);
303 mpz_add (end
, end
, *repeat
);
304 if (spec_size (ref
->u
.ar
.as
, &size
))
306 if (mpz_cmp (end
, size
) > 0)
309 gfc_error ("Data element above array upper bound at %L",
316 con
= gfc_constructor_lookup (expr
->value
.constructor
,
317 mpz_get_si (offset
));
320 con
= gfc_constructor_lookup_next (expr
->value
.constructor
,
321 mpz_get_si (offset
));
322 if (con
!= NULL
&& mpz_cmp (con
->offset
, end
) >= 0)
326 /* Overwriting an existing initializer is non-standard but
327 usually only provokes a warning from other compilers. */
328 if (con
!= NULL
&& con
->expr
!= NULL
)
330 /* Order in which the expressions arrive here depends on
331 whether they are from data statements or F95 style
332 declarations. Therefore, check which is the most
335 exprd
= (LOCATION_LINE (con
->expr
->where
.lb
->location
)
336 > LOCATION_LINE (rvalue
->where
.lb
->location
))
337 ? con
->expr
: rvalue
;
338 if (gfc_notify_std (GFC_STD_GNU
,
339 "re-initialization of %qs at %L",
340 symbol
->name
, &exprd
->where
) == false)
346 gfc_constructor
*next_con
= gfc_constructor_next (con
);
348 if (mpz_cmp (con
->offset
, end
) >= 0)
350 if (mpz_cmp (con
->offset
, offset
) < 0)
352 gcc_assert (mpz_cmp_si (con
->repeat
, 1) > 0);
353 mpz_sub (con
->repeat
, offset
, con
->offset
);
355 else if (mpz_cmp_si (con
->repeat
, 1) > 0
356 && mpz_get_si (con
->offset
)
357 + mpz_get_si (con
->repeat
) > mpz_get_si (end
))
361 = splay_tree_lookup (con
->base
,
362 mpz_get_si (con
->offset
));
364 && con
== (gfc_constructor
*) node
->value
365 && node
->key
== (splay_tree_key
)
366 mpz_get_si (con
->offset
));
367 endi
= mpz_get_si (con
->offset
)
368 + mpz_get_si (con
->repeat
);
369 if (endi
> mpz_get_si (end
) + 1)
370 mpz_set_si (con
->repeat
, endi
- mpz_get_si (end
));
372 mpz_set_si (con
->repeat
, 1);
373 mpz_set (con
->offset
, end
);
374 node
->key
= (splay_tree_key
) mpz_get_si (end
);
378 gfc_constructor_remove (con
);
382 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
383 NULL
, &rvalue
->where
,
384 mpz_get_si (offset
));
385 mpz_set (con
->repeat
, *repeat
);
393 if (spec_size (ref
->u
.ar
.as
, &size
))
395 if (mpz_cmp (offset
, size
) >= 0)
398 gfc_error ("Data element above array upper bound at %L",
406 con
= gfc_constructor_lookup (expr
->value
.constructor
,
407 mpz_get_si (offset
));
410 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
411 NULL
, &rvalue
->where
,
412 mpz_get_si (offset
));
414 else if (mpz_cmp_si (con
->repeat
, 1) > 0)
416 /* Need to split a range. */
417 if (mpz_cmp (con
->offset
, offset
) < 0)
419 gfc_constructor
*pred_con
= con
;
420 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
422 mpz_get_si (offset
));
423 con
->expr
= gfc_copy_expr (pred_con
->expr
);
424 mpz_add (con
->repeat
, pred_con
->offset
, pred_con
->repeat
);
425 mpz_sub (con
->repeat
, con
->repeat
, offset
);
426 mpz_sub (pred_con
->repeat
, offset
, pred_con
->offset
);
428 if (mpz_cmp_si (con
->repeat
, 1) > 0)
430 gfc_constructor
*succ_con
;
432 = gfc_constructor_insert_expr (&expr
->value
.constructor
,
434 mpz_get_si (offset
) + 1);
435 succ_con
->expr
= gfc_copy_expr (con
->expr
);
436 mpz_sub_ui (succ_con
->repeat
, con
->repeat
, 1);
437 mpz_set_si (con
->repeat
, 1);
445 /* Setup the expression to hold the constructor. */
446 expr
->expr_type
= EXPR_STRUCTURE
;
447 expr
->ts
.type
= BT_DERIVED
;
448 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
451 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
452 last_ts
= &ref
->u
.c
.component
->ts
;
454 /* Find the same element in the existing constructor. */
455 con
= find_con_by_component (ref
->u
.c
.component
,
456 expr
->value
.constructor
);
460 /* Create a new constructor. */
461 con
= gfc_constructor_append_expr (&expr
->value
.constructor
,
463 con
->n
.component
= ref
->u
.c
.component
;
473 /* Point the container at the new expression. */
474 if (last_con
== NULL
)
475 symbol
->value
= expr
;
477 last_con
->expr
= expr
;
484 gcc_assert (repeat
== NULL
);
486 /* Overwriting an existing initializer is non-standard but usually only
487 provokes a warning from other compilers. */
488 if (init
!= NULL
&& init
->where
.lb
&& rvalue
->where
.lb
)
490 /* Order in which the expressions arrive here depends on whether
491 they are from data statements or F95 style declarations.
492 Therefore, check which is the most recent. */
493 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
494 > LOCATION_LINE (rvalue
->where
.lb
->location
))
496 if (gfc_notify_std (GFC_STD_GNU
, "re-initialization of %qs at %L",
497 symbol
->name
, &expr
->where
) == false)
501 if (ref
|| last_ts
->type
== BT_CHARACTER
)
503 /* An initializer has to be constant. */
504 if (rvalue
->expr_type
!= EXPR_CONSTANT
505 || (lvalue
->ts
.u
.cl
->length
== NULL
506 && !(ref
&& ref
->u
.ss
.length
!= NULL
)))
508 expr
= create_character_initializer (init
, last_ts
, ref
, rvalue
);
512 if (lvalue
->ts
.type
== BT_DERIVED
513 && gfc_has_default_initializer (lvalue
->ts
.u
.derived
))
515 gfc_error ("Nonpointer object %qs with default initialization "
516 "shall not appear in a DATA statement at %L",
517 symbol
->name
, &lvalue
->where
);
521 expr
= gfc_copy_expr (rvalue
);
522 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
523 gfc_convert_type (expr
, &lvalue
->ts
, 0);
526 if (last_con
== NULL
)
527 symbol
->value
= expr
;
529 last_con
->expr
= expr
;
535 gfc_free_expr (expr
);
541 /* Modify the index of array section and re-calculate the array offset. */
544 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
552 gfc_expr
*start
, *end
, *stride
;
554 for (i
= 0; i
< ar
->dimen
; i
++)
556 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
561 stride
= gfc_copy_expr(ar
->stride
[i
]);
562 if(!gfc_simplify_expr(stride
, 1))
563 gfc_internal_error("Simplification error");
564 mpz_add (section_index
[i
], section_index
[i
],
565 stride
->value
.integer
);
566 if (mpz_cmp_si (stride
->value
.integer
, 0) >= 0)
570 gfc_free_expr(stride
);
574 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
580 end
= gfc_copy_expr(ar
->end
[i
]);
581 if(!gfc_simplify_expr(end
, 1))
582 gfc_internal_error("Simplification error");
583 cmp
= mpz_cmp (section_index
[i
], end
->value
.integer
);
587 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
589 if ((cmp
> 0 && forwards
) || (cmp
< 0 && !forwards
))
591 /* Reset index to start, then loop to advance the next index. */
594 start
= gfc_copy_expr(ar
->start
[i
]);
595 if(!gfc_simplify_expr(start
, 1))
596 gfc_internal_error("Simplification error");
597 mpz_set (section_index
[i
], start
->value
.integer
);
598 gfc_free_expr(start
);
601 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
607 mpz_set_si (*offset_ret
, 0);
608 mpz_init_set_si (delta
, 1);
610 for (i
= 0; i
< ar
->dimen
; i
++)
612 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
613 mpz_mul (tmp
, tmp
, delta
);
614 mpz_add (*offset_ret
, tmp
, *offset_ret
);
616 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
617 ar
->as
->lower
[i
]->value
.integer
);
618 mpz_add_ui (tmp
, tmp
, 1);
619 mpz_mul (delta
, tmp
, delta
);
626 /* Rearrange a structure constructor so the elements are in the specified
627 order. Also insert NULL entries if necessary. */
630 formalize_structure_cons (gfc_expr
*expr
)
632 gfc_constructor_base base
= NULL
;
633 gfc_constructor
*cur
;
634 gfc_component
*order
;
636 /* Constructor is already formalized. */
637 cur
= gfc_constructor_first (expr
->value
.constructor
);
638 if (!cur
|| cur
->n
.component
== NULL
)
641 for (order
= expr
->ts
.u
.derived
->components
; order
; order
= order
->next
)
643 cur
= find_con_by_component (order
, expr
->value
.constructor
);
645 gfc_constructor_append_expr (&base
, cur
->expr
, &cur
->expr
->where
);
647 gfc_constructor_append_expr (&base
, NULL
, NULL
);
650 /* For all what it's worth, one would expect
651 gfc_constructor_free (expr->value.constructor);
652 here. However, if the constructor is actually free'd,
653 hell breaks loose in the testsuite?! */
655 expr
->value
.constructor
= base
;
659 /* Make sure an initialization expression is in normalized form, i.e., all
660 elements of the constructors are in the correct order. */
663 formalize_init_expr (gfc_expr
*expr
)
671 type
= expr
->expr_type
;
675 for (c
= gfc_constructor_first (expr
->value
.constructor
);
676 c
; c
= gfc_constructor_next (c
))
677 formalize_init_expr (c
->expr
);
682 formalize_structure_cons (expr
);
691 /* Resolve symbol's initial value after all data statement. */
694 gfc_formalize_init_value (gfc_symbol
*sym
)
696 formalize_init_expr (sym
->value
);
700 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
704 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
711 mpz_set_si (*offset
, 0);
713 mpz_init_set_si (delta
, 1);
714 for (i
= 0; i
< ar
->dimen
; i
++)
716 mpz_init (section_index
[i
]);
717 switch (ar
->dimen_type
[i
])
723 start
= gfc_copy_expr(ar
->start
[i
]);
724 if(!gfc_simplify_expr(start
, 1))
725 gfc_internal_error("Simplification error");
726 mpz_sub (tmp
, start
->value
.integer
,
727 ar
->as
->lower
[i
]->value
.integer
);
728 mpz_mul (tmp
, tmp
, delta
);
729 mpz_add (*offset
, tmp
, *offset
);
730 mpz_set (section_index
[i
], start
->value
.integer
);
731 gfc_free_expr(start
);
734 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
738 gfc_internal_error ("TODO: Vector sections in data statements");
744 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
745 ar
->as
->lower
[i
]->value
.integer
);
746 mpz_add_ui (tmp
, tmp
, 1);
747 mpz_mul (delta
, tmp
, delta
);