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
)
110 gfc_extract_int (ts
->u
.cl
->length
, &len
);
114 /* Create a new initializer. */
115 init
= gfc_get_character_expr (ts
->kind
, NULL
, NULL
, len
);
119 dest
= init
->value
.character
.string
;
123 gfc_expr
*start_expr
, *end_expr
;
125 gcc_assert (ref
->type
== REF_SUBSTRING
);
127 /* Only set a substring of the destination. Fortran substring bounds
128 are one-based [start, end], we want zero based [start, end). */
129 start_expr
= gfc_copy_expr (ref
->u
.ss
.start
);
130 end_expr
= gfc_copy_expr (ref
->u
.ss
.end
);
132 if ((gfc_simplify_expr (start_expr
, 1) == FAILURE
)
133 || (gfc_simplify_expr (end_expr
, 1)) == FAILURE
)
135 gfc_error ("failure to simplify substring reference in DATA "
136 "statement at %L", &ref
->u
.ss
.start
->where
);
140 gfc_extract_int (start_expr
, &start
);
141 gfc_free_expr (start_expr
);
143 gfc_extract_int (end_expr
, &end
);
144 gfc_free_expr (end_expr
);
148 /* Set the whole string. */
153 /* Copy the initial value. */
154 if (rvalue
->ts
.type
== BT_HOLLERITH
)
155 len
= rvalue
->representation
.length
- rvalue
->ts
.u
.pad
;
157 len
= rvalue
->value
.character
.length
;
159 if (len
> end
- start
)
161 gfc_warning_now ("Initialization string starting at %L was "
162 "truncated to fit the variable (%d/%d)",
163 &rvalue
->where
, end
- start
, len
);
167 if (rvalue
->ts
.type
== BT_HOLLERITH
)
170 for (i
= 0; i
< len
; i
++)
171 dest
[start
+i
] = rvalue
->representation
.string
[i
];
174 memcpy (&dest
[start
], rvalue
->value
.character
.string
,
175 len
* sizeof (gfc_char_t
));
177 /* Pad with spaces. Substrings will already be blanked. */
178 if (len
< end
- start
&& ref
== NULL
)
179 gfc_wide_memset (&dest
[start
+ len
], ' ', end
- (start
+ len
));
181 if (rvalue
->ts
.type
== BT_HOLLERITH
)
183 init
->representation
.length
= init
->value
.character
.length
;
184 init
->representation
.string
185 = gfc_widechar_to_char (init
->value
.character
.string
,
186 init
->value
.character
.length
);
193 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
194 LVALUE already has an initialization, we extend this, otherwise we
195 create a new one. If REPEAT is non-NULL, initialize *REPEAT
196 consecutive values in LVALUE the same value in RVALUE. In that case,
197 LVALUE must refer to a full array, not an array section. */
200 gfc_assign_data_value (gfc_expr
*lvalue
, gfc_expr
*rvalue
, mpz_t index
,
205 gfc_expr
*expr
= NULL
;
206 gfc_constructor
*con
;
207 gfc_constructor
*last_con
;
209 gfc_typespec
*last_ts
;
212 symbol
= lvalue
->symtree
->n
.sym
;
213 init
= symbol
->value
;
214 last_ts
= &symbol
->ts
;
216 mpz_init_set_si (offset
, 0);
218 /* Find/create the parent expressions for subobject references. */
219 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
221 /* Break out of the loop if we find a substring. */
222 if (ref
->type
== REF_SUBSTRING
)
224 /* A substring should always be the last subobject reference. */
225 gcc_assert (ref
->next
== NULL
);
229 /* Use the existing initializer expression if it exists. Otherwise
232 expr
= gfc_get_expr ();
236 /* Find or create this element. */
240 if (ref
->u
.ar
.as
->rank
== 0)
242 gcc_assert (ref
->u
.ar
.as
->corank
> 0);
248 if (init
&& expr
->expr_type
!= EXPR_ARRAY
)
250 gfc_error ("'%s' at %L already is initialized at %L",
251 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
,
258 /* The element typespec will be the same as the array
261 /* Setup the expression to hold the constructor. */
262 expr
->expr_type
= EXPR_ARRAY
;
263 expr
->rank
= ref
->u
.ar
.as
->rank
;
266 if (ref
->u
.ar
.type
== AR_ELEMENT
)
267 get_array_index (&ref
->u
.ar
, &offset
);
269 mpz_set (offset
, index
);
271 /* Check the bounds. */
272 if (mpz_cmp_si (offset
, 0) < 0)
274 gfc_error ("Data element below array lower bound at %L",
278 else if (repeat
!= NULL
279 && ref
->u
.ar
.type
!= AR_ELEMENT
)
282 gcc_assert (ref
->u
.ar
.type
== AR_FULL
283 && ref
->next
== NULL
);
284 mpz_init_set (end
, offset
);
285 mpz_add (end
, end
, *repeat
);
286 if (spec_size (ref
->u
.ar
.as
, &size
) == SUCCESS
)
288 if (mpz_cmp (end
, size
) > 0)
291 gfc_error ("Data element above array upper bound at %L",
298 con
= gfc_constructor_lookup (expr
->value
.constructor
,
299 mpz_get_si (offset
));
302 con
= gfc_constructor_lookup_next (expr
->value
.constructor
,
303 mpz_get_si (offset
));
304 if (con
!= NULL
&& mpz_cmp (con
->offset
, end
) >= 0)
308 /* Overwriting an existing initializer is non-standard but
309 usually only provokes a warning from other compilers. */
310 if (con
!= NULL
&& con
->expr
!= NULL
)
312 /* Order in which the expressions arrive here depends on
313 whether they are from data statements or F95 style
314 declarations. Therefore, check which is the most
317 exprd
= (LOCATION_LINE (con
->expr
->where
.lb
->location
)
318 > LOCATION_LINE (rvalue
->where
.lb
->location
))
319 ? con
->expr
: rvalue
;
320 if (gfc_notify_std (GFC_STD_GNU
,
321 "re-initialization of '%s' at %L",
322 symbol
->name
, &exprd
->where
) == FAILURE
)
328 gfc_constructor
*next_con
= gfc_constructor_next (con
);
330 if (mpz_cmp (con
->offset
, end
) >= 0)
332 if (mpz_cmp (con
->offset
, offset
) < 0)
334 gcc_assert (mpz_cmp_si (con
->repeat
, 1) > 0);
335 mpz_sub (con
->repeat
, offset
, con
->offset
);
337 else if (mpz_cmp_si (con
->repeat
, 1) > 0
338 && mpz_get_si (con
->offset
)
339 + mpz_get_si (con
->repeat
) > mpz_get_si (end
))
343 = splay_tree_lookup (con
->base
,
344 mpz_get_si (con
->offset
));
346 && con
== (gfc_constructor
*) node
->value
347 && node
->key
== (splay_tree_key
)
348 mpz_get_si (con
->offset
));
349 endi
= mpz_get_si (con
->offset
)
350 + mpz_get_si (con
->repeat
);
351 if (endi
> mpz_get_si (end
) + 1)
352 mpz_set_si (con
->repeat
, endi
- mpz_get_si (end
));
354 mpz_set_si (con
->repeat
, 1);
355 mpz_set (con
->offset
, end
);
356 node
->key
= (splay_tree_key
) mpz_get_si (end
);
360 gfc_constructor_remove (con
);
364 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
365 NULL
, &rvalue
->where
,
366 mpz_get_si (offset
));
367 mpz_set (con
->repeat
, *repeat
);
375 if (spec_size (ref
->u
.ar
.as
, &size
) == SUCCESS
)
377 if (mpz_cmp (offset
, size
) >= 0)
380 gfc_error ("Data element above array upper bound at %L",
388 con
= gfc_constructor_lookup (expr
->value
.constructor
,
389 mpz_get_si (offset
));
392 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
393 NULL
, &rvalue
->where
,
394 mpz_get_si (offset
));
396 else if (mpz_cmp_si (con
->repeat
, 1) > 0)
398 /* Need to split a range. */
399 if (mpz_cmp (con
->offset
, offset
) < 0)
401 gfc_constructor
*pred_con
= con
;
402 con
= gfc_constructor_insert_expr (&expr
->value
.constructor
,
404 mpz_get_si (offset
));
405 con
->expr
= gfc_copy_expr (pred_con
->expr
);
406 mpz_add (con
->repeat
, pred_con
->offset
, pred_con
->repeat
);
407 mpz_sub (con
->repeat
, con
->repeat
, offset
);
408 mpz_sub (pred_con
->repeat
, offset
, pred_con
->offset
);
410 if (mpz_cmp_si (con
->repeat
, 1) > 0)
412 gfc_constructor
*succ_con
;
414 = gfc_constructor_insert_expr (&expr
->value
.constructor
,
416 mpz_get_si (offset
) + 1);
417 succ_con
->expr
= gfc_copy_expr (con
->expr
);
418 mpz_sub_ui (succ_con
->repeat
, con
->repeat
, 1);
419 mpz_set_si (con
->repeat
, 1);
427 /* Setup the expression to hold the constructor. */
428 expr
->expr_type
= EXPR_STRUCTURE
;
429 expr
->ts
.type
= BT_DERIVED
;
430 expr
->ts
.u
.derived
= ref
->u
.c
.sym
;
433 gcc_assert (expr
->expr_type
== EXPR_STRUCTURE
);
434 last_ts
= &ref
->u
.c
.component
->ts
;
436 /* Find the same element in the existing constructor. */
437 con
= find_con_by_component (ref
->u
.c
.component
,
438 expr
->value
.constructor
);
442 /* Create a new constructor. */
443 con
= gfc_constructor_append_expr (&expr
->value
.constructor
,
445 con
->n
.component
= ref
->u
.c
.component
;
455 /* Point the container at the new expression. */
456 if (last_con
== NULL
)
457 symbol
->value
= expr
;
459 last_con
->expr
= expr
;
466 gcc_assert (repeat
== NULL
);
468 if (ref
|| last_ts
->type
== BT_CHARACTER
)
470 if (lvalue
->ts
.u
.cl
->length
== NULL
&& !(ref
&& ref
->u
.ss
.length
!= NULL
))
472 expr
= create_character_initializer (init
, last_ts
, ref
, rvalue
);
476 /* Overwriting an existing initializer is non-standard but usually only
477 provokes a warning from other compilers. */
480 /* Order in which the expressions arrive here depends on whether
481 they are from data statements or F95 style declarations.
482 Therefore, check which is the most recent. */
483 expr
= (LOCATION_LINE (init
->where
.lb
->location
)
484 > LOCATION_LINE (rvalue
->where
.lb
->location
))
486 if (gfc_notify_std (GFC_STD_GNU
,
487 "re-initialization of '%s' at %L",
488 symbol
->name
, &expr
->where
) == FAILURE
)
492 expr
= gfc_copy_expr (rvalue
);
493 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
494 gfc_convert_type (expr
, &lvalue
->ts
, 0);
497 if (last_con
== NULL
)
498 symbol
->value
= expr
;
500 last_con
->expr
= expr
;
506 gfc_free_expr (expr
);
512 /* Modify the index of array section and re-calculate the array offset. */
515 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
524 for (i
= 0; i
< ar
->dimen
; i
++)
526 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
531 mpz_add (section_index
[i
], section_index
[i
],
532 ar
->stride
[i
]->value
.integer
);
533 if (mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0) >= 0)
540 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
545 cmp
= mpz_cmp (section_index
[i
], ar
->end
[i
]->value
.integer
);
547 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
549 if ((cmp
> 0 && forwards
) || (cmp
< 0 && !forwards
))
551 /* Reset index to start, then loop to advance the next index. */
553 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
555 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
561 mpz_set_si (*offset_ret
, 0);
562 mpz_init_set_si (delta
, 1);
564 for (i
= 0; i
< ar
->dimen
; i
++)
566 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
567 mpz_mul (tmp
, tmp
, delta
);
568 mpz_add (*offset_ret
, tmp
, *offset_ret
);
570 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
571 ar
->as
->lower
[i
]->value
.integer
);
572 mpz_add_ui (tmp
, tmp
, 1);
573 mpz_mul (delta
, tmp
, delta
);
580 /* Rearrange a structure constructor so the elements are in the specified
581 order. Also insert NULL entries if necessary. */
584 formalize_structure_cons (gfc_expr
*expr
)
586 gfc_constructor_base base
= NULL
;
587 gfc_constructor
*cur
;
588 gfc_component
*order
;
590 /* Constructor is already formalized. */
591 cur
= gfc_constructor_first (expr
->value
.constructor
);
592 if (!cur
|| cur
->n
.component
== NULL
)
595 for (order
= expr
->ts
.u
.derived
->components
; order
; order
= order
->next
)
597 cur
= find_con_by_component (order
, expr
->value
.constructor
);
599 gfc_constructor_append_expr (&base
, cur
->expr
, &cur
->expr
->where
);
601 gfc_constructor_append_expr (&base
, NULL
, NULL
);
604 /* For all what it's worth, one would expect
605 gfc_constructor_free (expr->value.constructor);
606 here. However, if the constructor is actually free'd,
607 hell breaks loose in the testsuite?! */
609 expr
->value
.constructor
= base
;
613 /* Make sure an initialization expression is in normalized form, i.e., all
614 elements of the constructors are in the correct order. */
617 formalize_init_expr (gfc_expr
*expr
)
625 type
= expr
->expr_type
;
629 for (c
= gfc_constructor_first (expr
->value
.constructor
);
630 c
; c
= gfc_constructor_next (c
))
631 formalize_init_expr (c
->expr
);
636 formalize_structure_cons (expr
);
645 /* Resolve symbol's initial value after all data statement. */
648 gfc_formalize_init_value (gfc_symbol
*sym
)
650 formalize_init_expr (sym
->value
);
654 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
658 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
664 mpz_set_si (*offset
, 0);
666 mpz_init_set_si (delta
, 1);
667 for (i
= 0; i
< ar
->dimen
; i
++)
669 mpz_init (section_index
[i
]);
670 switch (ar
->dimen_type
[i
])
676 mpz_sub (tmp
, ar
->start
[i
]->value
.integer
,
677 ar
->as
->lower
[i
]->value
.integer
);
678 mpz_mul (tmp
, tmp
, delta
);
679 mpz_add (*offset
, tmp
, *offset
);
680 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
683 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
687 gfc_internal_error ("TODO: Vector sections in data statements");
693 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
694 ar
->as
->lower
[i
]->value
.integer
);
695 mpz_add_ui (tmp
, tmp
, 1);
696 mpz_mul (delta
, tmp
, delta
);