From: Tobias Burnus Date: Tue, 16 Oct 2018 18:37:08 +0000 (+0200) Subject: Fix bounds with ALLOCATE with source-expr X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c152593057a3315c3e11343efb2717d5fa8b5df0;p=gcc.git Fix bounds with ALLOCATE with source-expr 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. From-SVN: r265212 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index af57bdeb8ac..1d9d65ccd68 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2018-10-16 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. + 2018-10-16 Tobias Burnus PR fortran/87556 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 130e67ba1e4..c778df06329 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5801,6 +5801,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; @@ -6236,6 +6237,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. */ @@ -6319,12 +6331,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/ChangeLog b/gcc/testsuite/ChangeLog index 37a9ed3f5b7..59bada061f4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-10-16 Tobias Burnus + + PR fortran/67125 + * gfortran.dg/allocate_with_source_26.f90: New. + 2018-10-15 David Malcolm * gcc.dg/missing-header-fixit-3.c: Update expected indentation 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