Commit 7de7ae18 by Paul Thomas

re PR fortran/52012 (Wrong-code with realloc on assignment and RESHAPE w/ ORDER=)

2012-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52012
	* trans-expr.c (fcncall_realloc_result): If variable shape is
	correct, retain the bounds, whatever they are.

2012-02-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52012
	* gfortran.dg/realloc_on_assign_11.f90: New test.

From-SVN: r183849
parent 1b3f07c7
2012-02-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/52012
* trans-expr.c (fcncall_realloc_result): If variable shape is
correct, retain the bounds, whatever they are.
2012-02-02 Tobias Burnus <burnus@net-b.de> 2012-02-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52093 PR fortran/52093
......
...@@ -6276,7 +6276,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, ...@@ -6276,7 +6276,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
} }
/* For Assignment to a reallocatable lhs from intrinsic functions, /* For assignment to a reallocatable lhs from intrinsic functions,
replace the se.expr (ie. the result) with a temporary descriptor. replace the se.expr (ie. the result) with a temporary descriptor.
Null the data field so that the library allocates space for the Null the data field so that the library allocates space for the
result. Free the data of the original descriptor after the function, result. Free the data of the original descriptor after the function,
...@@ -6290,44 +6290,88 @@ fcncall_realloc_result (gfc_se *se, int rank) ...@@ -6290,44 +6290,88 @@ fcncall_realloc_result (gfc_se *se, int rank)
tree res_desc; tree res_desc;
tree tmp; tree tmp;
tree offset; tree offset;
tree zero_cond;
int n; int n;
/* Use the allocation done by the library. Substitute the lhs /* Use the allocation done by the library. Substitute the lhs
descriptor with a copy, whose data field is nulled.*/ descriptor with a copy, whose data field is nulled.*/
desc = build_fold_indirect_ref_loc (input_location, se->expr); desc = build_fold_indirect_ref_loc (input_location, se->expr);
/* Unallocated, the descriptor does not have a dtype. */ /* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc); tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
res_desc = gfc_evaluate_now (desc, &se->pre); res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc); se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
/* Free the lhs after the function call and copy the result to /* Free the lhs after the function call and copy the result data to
the lhs descriptor. */ the lhs descriptor. */
tmp = gfc_conv_descriptor_data_get (desc); tmp = gfc_conv_descriptor_data_get (desc);
zero_cond = fold_build2_loc (input_location, EQ_EXPR,
boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
zero_cond = gfc_evaluate_now (zero_cond, &se->post);
tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp)); tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
gfc_add_expr_to_block (&se->post, tmp); gfc_add_expr_to_block (&se->post, tmp);
gfc_add_modify (&se->post, desc, res_desc);
offset = gfc_index_zero_node; tmp = gfc_conv_descriptor_data_get (res_desc);
gfc_conv_descriptor_data_set (&se->post, desc, tmp);
/* Now reset the bounds from zero based to unity based and set the /* Check that the shapes are the same between lhs and expression. */
offset accordingly. */ for (n = 0 ; n < rank; n++)
{
tree tmp1;
tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tmp, tmp1);
tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tmp, tmp1);
tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tmp, tmp1);
tmp = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tmp,
gfc_index_zero_node);
tmp = gfc_evaluate_now (tmp, &se->post);
zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
boolean_type_node, tmp,
zero_cond);
}
/* 'zero_cond' being true is equal to lhs not being allocated or the
shapes being different. */
zero_cond = gfc_evaluate_now (zero_cond, &se->post);
/* Now reset the bounds returned from the function call to bounds based
on the lhs lbounds, except where the lhs is not allocated or the shapes
of 'variable and 'expr' are different. Set the offset accordingly. */
offset = gfc_index_zero_node;
for (n = 0 ; n < rank; n++) for (n = 0 ; n < rank; n++)
{ {
tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); tree lbound;
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
lbound = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, zero_cond,
gfc_index_one_node, lbound);
lbound = gfc_evaluate_now (lbound, &se->post);
tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR, tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, gfc_array_index_type, tmp, lbound);
tmp, gfc_index_one_node);
gfc_conv_descriptor_lbound_set (&se->post, desc, gfc_conv_descriptor_lbound_set (&se->post, desc,
gfc_rank_cst[n], gfc_rank_cst[n], lbound);
gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&se->post, desc, gfc_conv_descriptor_ubound_set (&se->post, desc,
gfc_rank_cst[n], tmp); gfc_rank_cst[n], tmp);
/* Accumulate the offset. Since all lbounds are unity, offset /* Accumulate the offset. */
is just minus the sum of the strides. */
tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]); tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
lbound, tmp);
offset = fold_build2_loc (input_location, MINUS_EXPR, offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, gfc_array_index_type,
offset, tmp); offset, tmp);
......
2012-02-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/52012
* gfortran.dg/realloc_on_assign_11.f90: New test.
2012-02-02 Tobias Burnus <burnus@net-b.de> 2012-02-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52093 PR fortran/52093
......
! { dg-do run }
! PR52012 - tests of automatic reallocation on assignment for variable = array_intrinsic
!
! Contributed by Tobias Burnus and Dominique Dhumieres
!
integer, allocatable :: a(:), b(:), e(:,:)
integer :: c(1:5,1:5), d(1:5,1:5)
allocate(b(3))
b = [1,2,3]
! Shape conforms so bounds follow allocation.
allocate (a(7:9))
a = reshape( b, shape=[size(b)])
if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [7,9,3,3])) call abort
deallocate (a)
! 'a' not allocated so lbound defaults to 1.
a = reshape( b, shape=[size(b)])
if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [1,3,3,3])) call abort
deallocate (a)
! Shape conforms so bounds follow allocation.
allocate (a(0:0))
a(0) = 1
if (any ([lbound(a), ubound(a), size(a), shape (a)] .ne. [0,0,1,1])) call abort
! 'a' not allocated so lbound defaults to 1.
e = matmul (c(2:5,:), d(:, 3:4))
if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [1,1,4,2,8,4,2])) call abort
deallocate (e)
! Shape conforms so bounds follow allocation.
allocate (e(4:7, 11:12))
e = matmul (c(2:5,:), d(:, 3:4))
if (any ([lbound(e), ubound(e), size(e), shape (e)] .ne. [4,11,7,12,8,4,2])) call abort
end
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