From: Paul Thomas Date: Fri, 3 Feb 2012 18:33:58 +0000 (+0000) Subject: re PR fortran/52012 (Wrong-code with realloc on assignment and RESHAPE w/ ORDER=) X-Git-Tag: releases/gcc-4.6.3~127 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=11bf738bad1a015e90c62d616f7d9b23d31d2655;p=thirdparty%2Fgcc.git re PR fortran/52012 (Wrong-code with realloc on assignment and RESHAPE w/ ORDER=) 2012-02-03 Paul Thomas PR fortran/52012 * trans-expr.c (fcncall_realloc_result): Correct calculation of result offset. If variable shape is correct, retain the bounds, whatever they are. 2012-02-03 Paul Thomas PR fortran/52012 * gfortran.dg/realloc_on_assign_10.f90: New test. * gfortran.dg/realloc_on_assign_11.f90: New test. From-SVN: r183874 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 54bc970688be..f06158d9bd35 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2012-02-03 Paul Thomas + + PR fortran/52012 + * trans-expr.c (fcncall_realloc_result): Correct calculation of + result offset. If variable shape is correct, retain the bounds, + whatever they are. + 2012-01-28 Tobias Burnus PR fortran/52022 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0eec9cee92d2..c0c4c6fe9210 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1,6 +1,6 @@ /* Expression translation Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, - 2011 + 2011, 2012 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -5536,7 +5536,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. Null the data field so that the library allocates space for the result. Free the data of the original descriptor after the function, @@ -5550,55 +5550,95 @@ fcncall_realloc_result (gfc_se *se, int rank) tree res_desc; tree tmp; tree offset; + tree zero_cond; int n; /* Use the allocation done by the library. Substitute the lhs descriptor with a copy, whose data field is nulled.*/ desc = build_fold_indirect_ref_loc (input_location, se->expr); + /* Unallocated, the descriptor does not have a dtype. */ tmp = gfc_conv_descriptor_dtype (desc); gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + res_desc = gfc_evaluate_now (desc, &se->pre); gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); 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. */ 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)); gfc_add_expr_to_block (&se->post, tmp); - gfc_add_modify (&se->post, desc, res_desc); + tmp = gfc_conv_descriptor_data_get (res_desc); + gfc_conv_descriptor_data_set (&se->post, desc, tmp); + + /* Check that the shapes are the same between lhs and expression. */ + 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; - tmp = gfc_index_one_node; - /* Now reset the bounds from zero based to unity based. */ for (n = 0 ; n < rank; n++) { - /* Accumulate the offset. */ - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp); - /* Now do the bounds. */ - gfc_conv_descriptor_offset_set (&se->post, desc, tmp); - 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, - gfc_array_index_type, - tmp, gfc_index_one_node); + gfc_array_index_type, tmp, lbound); gfc_conv_descriptor_lbound_set (&se->post, desc, - gfc_rank_cst[n], - gfc_index_one_node); + gfc_rank_cst[n], lbound); gfc_conv_descriptor_ubound_set (&se->post, desc, gfc_rank_cst[n], tmp); - /* The extent for the next contribution to offset. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); + /* Accumulate the offset. */ + 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, + gfc_array_index_type, + offset, tmp); + offset = gfc_evaluate_now (offset, &se->post); + } + gfc_conv_descriptor_offset_set (&se->post, desc, offset); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cdf775535064..517b3d5c76b6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2012-02-03 Paul Thomas + + PR fortran/52012 + * gfortran.dg/realloc_on_assign_10.f90: New test. + * gfortran.dg/realloc_on_assign_11.f90: New test. + 2012-01-12 Georg-Johann Lay Backport from mainline r183796 diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90 new file mode 100644 index 000000000000..787a56ae9e9a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_10.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR52012 - with realloc_lhs active(ie. default condition) the +! offset was wrongly calculated for a, after assignment. +! +! Reported by Reinhold Bader and Tobias Burnus +! +program gf + implicit none + real, allocatable :: a(:,:,:) + real, parameter :: zero = 0.0, one = 1.0 + real :: b(3,4,5) = zero + b(1,2,3) = one + allocate (a(size (b, 3), size (b, 2), size (b, 1))) + a = reshape (b, shape (a), order = [3, 2, 1]) + if (any (a(:, 2, 1) .ne. [zero, zero, one, zero, zero])) call abort + if (a(3, 2, 1) /= one) call abort() + if (sum (abs (a)) /= one) call abort() +end program diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90 new file mode 100644 index 000000000000..ab96bb9deaf8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_11.f90 @@ -0,0 +1,36 @@ +! { 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