This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR47071 - [4.6 Regression] Wrong reallocate
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: gcc-patches <gcc-patches at gcc dot gnu dot org>, fortran at gcc dot gnu dot org
- Date: Mon, 10 Jan 2011 06:38:04 +0100
- Subject: [Patch, fortran] PR47071 - [4.6 Regression] Wrong reallocate
F2003 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. If variable is or
becomes an unallocated allocatable 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 )."
This ensures that valid F95 code works as expected, since comforming
variable and expr should be assigned as if the variable were not
allocatable.
gfortran was testing only for size and not shape. In addition, before
reallocation was done, the bounds were changed, regardless of the
shape. This incorrect behaviour was reinforced by being identical to
that of another product.
Many thanks to Joost VandeVondele for reporting this.
The patch looks MUCH more complicated than it actually is. The
required behaviour is obtained by moving chunks of code around and
eliminating the test for size. I have added extra comments. A
specific test is not needed since the correction to
realloc_on_assign.f03 covers it.
Note that we still have to deal with changing length parameters; eg.
character length or dynamic type. Realistically, I think that this
will come in 4.7 but I will see what I can do:-)
Bootstraps and regtests on FC9/x86_64 - OK for trunk?
Paul
2011-01-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/47051
* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
to be standard compliant by testing for shape rather than size
before skipping reallocation. Improve comments.
2011-01-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/47051
* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
standard compliant and comment.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 168599)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 6877,6911 ****
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);
--- 6877,6887 ----
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
*** 6917,6928 ****
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)
--- 6893,6899 ----
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
*** 6936,6986 ****
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.
--- 6907,6973 ----
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
*** 6988,6994 ****
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;
--- 6975,6983 ----
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;
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (revision 168599)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (working copy)
***************
*** 3,8 ****
--- 3,9 ----
! 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
*** 28,41 ****
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
!
--- 29,49 ----
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
!