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
This commit is contained in:
Paul Thomas
parent
b7e945c8e7
commit
93c3bf479d
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
!
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user