===================================================================
*************** gfc_alloc_allocatable_for_assignment (gf
desc = lss->data.info.descriptor;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
- size1 = gfc_conv_descriptor_size (desc, expr1->rank);
-
- /* Get the rhs size. Fix both sizes. */
- if (expr2)
- desc2 = rss->data.info.descriptor;
- else
- desc2 = NULL_TREE;
- size2 = gfc_index_one_node;
- for (n = 0; n < expr2->rank; n++)
- {
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[n], loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
- size2 = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- tmp, size2);
- }
- size1 = gfc_evaluate_now (size1, &fblock);
- size2 = gfc_evaluate_now (size2, &fblock);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- size1, size2);
- neq_size = gfc_evaluate_now (cond, &fblock);
! /* If the lhs is allocated and the lhs and rhs are equal length, jump
! past the realloc/malloc. This allows F95 compliant expressions
! to escape allocation on assignment. */
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);
desc = lss->data.info.descriptor;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
! /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
! deallocated if expr is an array of different shape or any of the
! corresponding length type parameter values of variable and expr
! differ." This assures F95 compatibility. */
jump_label1 = gfc_build_label_decl (NULL_TREE);
jump_label2 = gfc_build_label_decl (NULL_TREE);
*************** gfc_alloc_allocatable_for_assignment (gf
build_empty_stmt (input_location));
gfc_add_expr_to_block (&fblock, tmp);
! /* Reallocate if sizes are different. */
! tmp = build3_v (COND_EXPR, neq_size,
! build1_v (GOTO_EXPR, jump_label1),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&fblock, tmp);
!
if (expr2 && expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym
&& expr2->value.function.isym->conversion)
build_empty_stmt (input_location));
gfc_add_expr_to_block (&fblock, tmp);
! /* Get arrayspec if expr is a full array. */
if (expr2 && expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym
&& expr2->value.function.isym->conversion)
*************** gfc_alloc_allocatable_for_assignment (gf
else
as = NULL;
! /* Reset the lhs bounds if any are different from the rhs. */
! if (as && expr2->expr_type == EXPR_VARIABLE)
{
! for (n = 0; n < expr1->rank; n++)
! {
! /* First check the lbounds. */
! dim = rss->data.info.dim[n];
! lbd = get_std_lbound (expr2, desc2, dim,
! as->type == AS_ASSUMED_SIZE);
! lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
! cond = fold_build2_loc (input_location, NE_EXPR,
! boolean_type_node, lbd, lbound);
! tmp = build3_v (COND_EXPR, cond,
! build1_v (GOTO_EXPR, jump_label1),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&fblock, tmp);
!
! /* Now check the shape. */
! tmp = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! loop->to[n], loop->from[n]);
! tmp = fold_build2_loc (input_location, PLUS_EXPR,
! gfc_array_index_type,
! tmp, lbound);
! ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
! tmp = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! tmp, ubound);
! cond = fold_build2_loc (input_location, NE_EXPR,
! boolean_type_node,
! tmp, gfc_index_zero_node);
! tmp = build3_v (COND_EXPR, cond,
! build1_v (GOTO_EXPR, jump_label1),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&fblock, tmp);
! }
}
! /* Otherwise jump past the (re)alloc code. */
! tmp = build1_v (GOTO_EXPR, jump_label2);
! gfc_add_expr_to_block (&fblock, tmp);
! /* Add the label to start automatic (re)allocation. */
! tmp = build1_v (LABEL_EXPR, jump_label1);
! gfc_add_expr_to_block (&fblock, tmp);
/* Now modify the lhs descriptor and the associated scalarizer
variables.
else
as = NULL;
! /* If the lhs shape is not the same as the rhs jump to setting the
! bounds and doing the reallocation....... */
! for (n = 0; n < expr1->rank; n++)
{
! /* Check the shape. */
! lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
! ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
! tmp = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! loop->to[n], loop->from[n]);
! tmp = fold_build2_loc (input_location, PLUS_EXPR,
! gfc_array_index_type,
! tmp, lbound);
! tmp = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! tmp, ubound);
! cond = fold_build2_loc (input_location, NE_EXPR,
! boolean_type_node,
! tmp, gfc_index_zero_node);
! tmp = build3_v (COND_EXPR, cond,
! build1_v (GOTO_EXPR, jump_label1),
! build_empty_stmt (input_location));
! gfc_add_expr_to_block (&fblock, tmp);
}
! /* ....else jump past the (re)alloc code. */
! tmp = build1_v (GOTO_EXPR, jump_label2);
! gfc_add_expr_to_block (&fblock, tmp);
! /* Add the label to start automatic (re)allocation. */
! tmp = build1_v (LABEL_EXPR, jump_label1);
! gfc_add_expr_to_block (&fblock, tmp);
!
! size1 = gfc_conv_descriptor_size (desc, expr1->rank);
!
! /* Get the rhs size. Fix both sizes. */
! if (expr2)
! desc2 = rss->data.info.descriptor;
! else
! desc2 = NULL_TREE;
! size2 = gfc_index_one_node;
! for (n = 0; n < expr2->rank; n++)
! {
! tmp = fold_build2_loc (input_location, MINUS_EXPR,
! gfc_array_index_type,
! loop->to[n], loop->from[n]);
! tmp = fold_build2_loc (input_location, PLUS_EXPR,
! gfc_array_index_type,
! tmp, gfc_index_one_node);
! size2 = fold_build2_loc (input_location, MULT_EXPR,
! gfc_array_index_type,
! tmp, size2);
! }
!
! size1 = gfc_evaluate_now (size1, &fblock);
! size2 = gfc_evaluate_now (size2, &fblock);
!
! cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
! size1, size2);
! neq_size = gfc_evaluate_now (cond, &fblock);
!
/* Now modify the lhs descriptor and the associated scalarizer
variables.
*************** gfc_alloc_allocatable_for_assignment (gf
variable, then it is allocated with each deferred type parameter
equal to the corresponding type parameters of expr , with the
shape of expr , and with each lower bound equal to the
! corresponding element of LBOUND(expr). */
size1 = gfc_index_one_node;
offset = gfc_index_zero_node;
variable, then it is allocated with each deferred type parameter
equal to the corresponding type parameters of expr , with the
shape of expr , and with each lower bound equal to the
! corresponding element of LBOUND(expr).
! Reuse size1 to keep a dimension-by-dimension track of the
! stride of the new array. */
size1 = gfc_index_one_node;
offset = gfc_index_zero_node;
===================================================================
***************
! reallocation of allocatable arrays on assignment. The tests
! below were generated in the final stages of the development of
! this patch.
+ ! test1 has been corrected for PR47051
!
! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
! and Tobias Burnus <burnus@gcc.gnu.org>
*************** contains
if (lbound (c, 1) .ne. lbound(a, 1)) call abort
if (ubound (c, 1) .ne. ubound(a, 1)) call abort
c=b
! if (lbound (c, 1) .ne. lbound(b, 1)) call abort
! if (ubound (c, 1) .ne. ubound(b, 1)) call abort
d=b
if (lbound (d, 1) .ne. lbound(b, 1)) call abort
if (ubound (d, 1) .ne. ubound(b, 1)) call abort
d=a
! if (lbound (d, 1) .ne. lbound(a, 1)) call abort
! if (ubound (d, 1) .ne. ubound(a, 1)) call abort
end subroutine
subroutine test2
!
if (lbound (c, 1) .ne. lbound(a, 1)) call abort
if (ubound (c, 1) .ne. ubound(a, 1)) call abort
c=b
! ! 7.4.1.3 "If variable is an allocated allocatable variable, it is
! ! deallocated if expr is an array of different shape or any of the
! ! corresponding length type parameter values of variable and expr
! ! differ." Here the shape is the same so the deallocation does not
! ! occur and the bounds are not recalculated. This was corrected
! ! for the fix of PR47051.
! if (lbound (c, 1) .ne. lbound(a, 1)) call abort
! if (ubound (c, 1) .ne. ubound(a, 1)) call abort
d=b
if (lbound (d, 1) .ne. lbound(b, 1)) call abort
if (ubound (d, 1) .ne. ubound(b, 1)) call abort
d=a
! ! The other PR47051 correction.
! if (lbound (d, 1) .ne. lbound(b, 1)) call abort
! if (ubound (d, 1) .ne. ubound(b, 1)) call abort
end subroutine
subroutine test2
!