OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/47051 (Wrong reallocate)

Browse Source 
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
This commit is contained in:
Paul Thomas 2011-01-11 05:19:20 +00:00
parent b7e945c8e7
commit 93c3bf479d
4 changed files with 99 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
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

159
gcc/fortran/trans-array.c
View File

@ -1,5 +1,6 @@
/* 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,6 +6878,69 @@ 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);
/* 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);
/* Allocate if data is NULL. */
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
tmp = build3_v (COND_EXPR, cond,
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)
{
/* For conversion functions, take the arg. */
gfc_expr *arg = expr2->value.function.actual->expr;
as = gfc_get_full_arrayspec_from_expr (arg);
}
else if (expr2)
as = gfc_get_full_arrayspec_from_expr (expr2);
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. */
@ -6897,98 +6961,23 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
/* Allocate if data is NULL. */
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
array1, build_int_cst (TREE_TYPE (array1), 0));
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label1),
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)
{
/* For conversion functions, take the arg. */
gfc_expr *arg = expr2->value.function.actual->expr;
as = gfc_get_full_arrayspec_from_expr (arg);
}
else if (expr2)
as = gfc_get_full_arrayspec_from_expr (expr2);
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.
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;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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

16
gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
View File

@ -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
!