From patchwork Mon Jan 10 05:38:04 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 78077 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 1E3C0B7120 for ; Mon, 10 Jan 2011 16:38:27 +1100 (EST) Received: (qmail 20446 invoked by alias); 10 Jan 2011 05:38:18 -0000 Received: (qmail 20132 invoked by uid 22791); 10 Jan 2011 05:38:14 -0000 X-SWARE-Spam-Status: No, hits=-2.1 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, RFC_ABUSE_POST, TW_LB X-Spam-Check-By: sourceware.org Received: from mail-ey0-f175.google.com (HELO mail-ey0-f175.google.com) (209.85.215.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 10 Jan 2011 05:38:08 +0000 Received: by eya28 with SMTP id 28so8407104eya.20 for ; Sun, 09 Jan 2011 21:38:05 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.31.78 with SMTP id x14mr1508694ebc.1.1294637884996; Sun, 09 Jan 2011 21:38:04 -0800 (PST) Received: by 10.213.3.15 with HTTP; Sun, 9 Jan 2011 21:38:04 -0800 (PST) Date: Mon, 10 Jan 2011 06:38:04 +0100 Message-ID: Subject: [Patch, fortran] PR47071 - [4.6 Regression] Wrong reallocate From: Paul Richard Thomas To: gcc-patches , fortran@gcc.gnu.org Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org F2003 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. 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 )." This ensures that valid F95 code works as expected, since comforming variable and expr should be assigned as if the variable were not allocatable. gfortran was testing only for size and not shape. In addition, before reallocation was done, the bounds were changed, regardless of the shape. This incorrect behaviour was reinforced by being identical to that of another product. Many thanks to Joost VandeVondele for reporting this. The patch looks MUCH more complicated than it actually is. The required behaviour is obtained by moving chunks of code around and eliminating the test for size. I have added extra comments. A specific test is not needed since the correction to realloc_on_assign.f03 covers it. Note that we still have to deal with changing length parameters; eg. character length or dynamic type. Realistically, I think that this will come in 4.7 but I will see what I can do:-) Bootstraps and regtests on FC9/x86_64 - OK for trunk? Paul 2011-01-10 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-10 Paul Thomas PR fortran/47051 * gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be standard compliant and comment. Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 168599) --- gcc/fortran/trans-array.c (working copy) *************** gfc_alloc_allocatable_for_assignment (gf *** 6877,6911 **** 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. */ jump_label1 = gfc_build_label_decl (NULL_TREE); jump_label2 = gfc_build_label_decl (NULL_TREE); --- 6877,6887 ---- 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); *************** gfc_alloc_allocatable_for_assignment (gf *** 6917,6928 **** 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) --- 6893,6899 ---- 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) *************** gfc_alloc_allocatable_for_assignment (gf *** 6936,6986 **** 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. --- 6907,6973 ---- 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. */ ! 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); ! /* Now modify the lhs descriptor and the associated scalarizer variables. *************** gfc_alloc_allocatable_for_assignment (gf *** 6988,6994 **** 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). */ size1 = gfc_index_one_node; offset = gfc_index_zero_node; --- 6975,6983 ---- 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; Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 =================================================================== *** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (revision 168599) --- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (working copy) *************** *** 3,8 **** --- 3,9 ---- ! 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 *************** contains *** 28,41 **** 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 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 end subroutine subroutine test2 ! --- 29,49 ---- if (lbound (c, 1) .ne. lbound(a, 1)) call abort if (ubound (c, 1) .ne. ubound(a, 1)) call abort c=b ! ! 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 ! ! 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 !