Skip to content

R
riscv-gcc-1
Commit 93c3bf47 by Paul Thomas
Options

re PR fortran/47051 (Wrong reallocate) 

2011-01-11  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-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47051
	* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
	standard compliant and comment.

From-SVN: r168650
parent b7e945c8
Showing with 96 additions and 86 deletions
gcc/fortran/ChangeLog
2011-01-11 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-09 Janus Weil <janus@gcc.gnu.org>
PR fortran/47224
......
gcc/fortran/trans-array.c
/* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
......@@ -6877,35 +6878,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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. */
/* 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);
......@@ -6917,12 +6894,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
/* Get arrayspec if expr is a full array. */
if (expr2 && expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym
&& expr2->value.function.isym->conversion)
......@@ -6936,59 +6908,76 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
as = NULL;
/* Reset the lhs bounds if any are different from the rhs. */
if (as && expr2->expr_type == EXPR_VARIABLE)
/* 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++)
{
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);
/* 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);
/* 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);
}
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);
}
/* 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);
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.
7.4.1.3: 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). */
variables. F2003 7.4.1.3: "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)."
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;
......
gcc/testsuite/ChangeLog
2011-01-11 Paul Thomas <pault@gcc.gnu.org>
PR fortran/47051
* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
standard compliant and comment.
2011-01-10 Jan Hubicka <jh@suse.cz>
PR lto/46083
......
gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
......@@ -3,6 +3,7 @@
! 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>
......@@ -28,14 +29,21 @@ 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
! 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
if (lbound (d, 1) .ne. lbound(a, 1)) call abort
if (ubound (d, 1) .ne. ubound(a, 1)) call abort
! 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
!
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment