From patchwork Fri Oct 12 11:28:55 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 982993 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-487442-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=physik.fu-berlin.de Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 42WlwQ0VpZz9s3Z for ; Fri, 12 Oct 2018 22:29:09 +1100 (AEDT) Received: (qmail 91901 invoked by alias); 12 Oct 2018 11:29:04 -0000 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 Received: (qmail 91864 invoked by uid 89); 12 Oct 2018 11:29:03 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-23.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_LAZY_DOMAIN_SECURITY autolearn=ham version=3.3.2 spammy=f2018, F2018, UD:trans-stmt.c, trans-stmt.c X-HELO: outpost19.zedat.fu-berlin.de Received: from outpost19.zedat.fu-berlin.de (HELO outpost19.zedat.fu-berlin.de) (130.133.4.112) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 12 Oct 2018 11:29:00 +0000 Received: from relay1.zedat.fu-berlin.de ([130.133.4.67]) by outpost.zedat.fu-berlin.de (Exim 4.85) with esmtps (TLSv1.2:DHE-RSA-AES256-GCM-SHA384:256) (envelope-from ) id <1gAvco-001v4i-NU>; Fri, 12 Oct 2018 13:28:58 +0200 Received: from mx.physik.fu-berlin.de ([160.45.64.218]) by relay1.zedat.fu-berlin.de (Exim 4.85) with esmtps (TLSv1.2:DHE-RSA-AES128-SHA:128) (envelope-from ) id <1gAvco-002noO-J2>; Fri, 12 Oct 2018 13:28:58 +0200 Received: from login2.physik.fu-berlin.de ([160.45.66.208]) by mx.physik.fu-berlin.de with esmtps (TLS1.2:RSA_AES_128_CBC_SHA1:128) (Exim 4.80) (envelope-from ) id 1gAvcl-0000BY-93; Fri, 12 Oct 2018 13:28:55 +0200 Received: from tburnus by login2.physik.fu-berlin.de with local (Exim 4.84_2 #2 (Debian)) id 1gAvcl-0003E5-7v; Fri, 12 Oct 2018 13:28:55 +0200 Date: Fri, 12 Oct 2018 13:28:55 +0200 From: Tobias Burnus To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [Patch, Fortran] PR67125 - ALLOCATE with source-expr lbounds/ubound off by one Message-ID: <20181012112854.GA11980@physik.fu-berlin.de> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) Sender: Tobias Burnus Hello all, "When an ALLOCATE statement is executed for an array with no allocate-shape-spec-list, the bounds of source-expr determine the bounds of the array." (F2018, 9.7.1.2 (6)) That seems to work fine for arrays which have an array descriptor. However, as the current code shows, it fails for array constructors where the lbound is zero instead of the expected one. It turns out (PR67125) that functions results which don't use array descriptors have the same problem as do stack/static allocated array variables (PR87580). I am not sure that my check for array descriptors is the best but it seems to work and fixes the problem. OK for the trunk? Build and regtested on x86-64-linux. Tobias 2018-10-12 Tobias Burnus PR fortran/67125 * trans-array.c (gfc_array_init_size, gfc_array_allocate): Rename argument e3_is_array_constr to e3_has_nodescriptor and update comments. * trans-stmt.c (gfc_trans_allocate): Also fix lower bound to 1 for nonalloc/nonpointer func results/vars besides array constructors. PR fortran/67125 * gfortran.dg/allocate_with_source_26.f90: New. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c4df4ebbc40..ea4cf8cd1b8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5333,7 +5333,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_is_array_constr, gfc_expr *expr) + tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr) { tree type; tree tmp; @@ -5412,10 +5412,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_init_se (&se, NULL); if (expr3_desc != NULL_TREE) { - if (e3_is_array_constr) - /* The lbound of a constant array [] starts at zero, but when - allocating it, the standard expects the array to start at - one. */ + if (e3_has_nodescriptor) + /* The lbound of nondescriptor arrays like array constructors, + nonallocatable/nonpointer function results/variables, + start at zero, but when allocating it, the standard expects + the array to start at one. */ se.expr = gfc_index_one_node; else se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, @@ -5451,12 +5452,13 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_init_se (&se, NULL); if (expr3_desc != NULL_TREE) { - if (e3_is_array_constr) + if (e3_has_nodescriptor) { - /* The lbound of a constant array [] starts at zero, but when - allocating it, the standard expects the array to start at - one. Therefore fix the upper bound to be - (desc.ubound - desc.lbound)+ 1. */ + /* The lbound of nondescriptor arrays like array constructors, + nonallocatable/nonpointer function results/variables, + start at zero, but when allocating it, the standard expects + the array to start at one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound) + 1. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, gfc_conv_descriptor_ubound_get ( @@ -5684,7 +5686,7 @@ bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_is_array_constr) + bool e3_has_nodescriptor) { tree tmp; tree pointer; @@ -5813,7 +5815,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, expr3_elem_size, nelems, expr3, e3_arr_desc, - e3_is_array_constr, expr); + e3_has_nodescriptor, expr); if (dimension) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6256e3fa805..52f7e8bdc5c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5784,6 +5784,7 @@ gfc_trans_allocate (gfc_code * code) tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; bool needs_caf_sync, caf_refs_comp; + bool e3_has_nodescriptor = false; gfc_symtree *newsym = NULL; symbol_attribute caf_attr; gfc_actual_arglist *param_list; @@ -6219,6 +6220,17 @@ gfc_trans_allocate (gfc_code * code) } else e3rhs = gfc_copy_expr (code->expr3); + + // We need to propagate the bounds of the expr3 for source=/mold=; + // however, for nondescriptor arrays, we use internally a lower bound + // of zero instead of one, which needs to be corrected for the allocate obj + if (e3_is == E3_DESC) + { + symbol_attribute attr = gfc_expr_attr (code->expr3); + if (code->expr3->expr_type == EXPR_ARRAY || + (!attr.allocatable && !attr.pointer)) + e3_has_nodescriptor = true; + } } /* Loop over all objects to allocate. */ @@ -6302,12 +6314,12 @@ gfc_trans_allocate (gfc_code * code) } else tmp = expr3_esize; + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, tmp, &nelems, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, - code->expr3 != NULL && e3_is == E3_DESC - && code->expr3->expr_type == EXPR_ARRAY)) + e3_has_nodescriptor)) { /* A scalar or derived type. First compute the size to allocate. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 new file mode 100644 index 00000000000..38127c06bc0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! +! Ensure that the lower bound starts with the correct +! value +! +! PR fortran/87580 +! PR fortran/67125 +! +! Contributed by Antony Lewis and mrestelli +! +program p + implicit none + integer, allocatable :: a(:), b(:), c(:), d(:), e(:) + integer :: vec(6) + + vec = [1,2,3,4,5,6] + + allocate(a, source=f(3)) + allocate(b, source=g(3)) + allocate(c, source=h(3)) + allocate(d, source=[1,2,3,4,5]) + allocate(e, source=vec) + + !write(*,*) lbound(a,1), ubound(a,1) ! prints 1 3 + !write(*,*) lbound(b,1), ubound(b,1) ! prints 1 3 + !write(*,*) lbound(c,1), ubound(c,1) ! prints 3 5 + !write(*,*) lbound(d,1), ubound(d,1) ! prints 1 5 + !write(*,*) lbound(e,1), ubound(e,1) ! prints 1 6 + + if (lbound(a,1) /= 1 .or. ubound(a,1) /= 3 & + .or. lbound(b,1) /= 1 .or. ubound(b,1) /= 3 & + .or. lbound(c,1) /= 3 .or. ubound(c,1) /= 5 & + .or. lbound(d,1) /= 1 .or. ubound(d,1) /= 5 & + .or. lbound(e,1) /= 1 .or. ubound(e,1) /= 6) then + call abort() + endif + +contains + + pure function f(i) + integer, intent(in) :: i + integer :: f(i) + f = 2*i + end function f + + pure function g(i) result(r) + integer, value, intent(in) :: i + integer, allocatable :: r(:) + r = [1,2,3] + end function g + + pure function h(i) result(r) + integer, value, intent(in) :: i + integer, allocatable :: r(:) + allocate(r(3:5)) + r = [1,2,3] + end function h +end program p