From: Paul Thomas Date: Tue, 11 Jan 2011 05:19:20 +0000 (+0000) Subject: re PR fortran/47051 (Wrong reallocate) X-Git-Tag: upstream/12.2.0~87202 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=93c3bf479df17e661b0e867696981565481701a0;p=platform%2Fupstream%2Fgcc.git re PR fortran/47051 (Wrong reallocate) 2011-01-11 Paul Thomas 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 PR fortran/47051 * gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be standard compliant and comment. From-SVN: r168650 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b8f3afe..c61ed92 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2011-01-11 Paul Thomas + + 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 PR fortran/47224 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b95dd90..4dc69d2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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 and Steven Bosscher @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6df0d8e..6a57865 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2011-01-11 Paul Thomas + + PR fortran/47051 + * gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be + standard compliant and comment. + 2011-01-10 Jan Hubicka PR lto/46083 diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 index ddcc316..e309110 100644 --- a/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 +++ b/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 ! and Tobias Burnus @@ -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 !