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 af57bdeb8ac99db6688758df32a63b4d7edaa898..1d9d65ccd685f6f2f3d3f74cdf8fca3b2cc34029 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2018-10-16  Tobias Burnus  <burnus@net-b.de>
+
+       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  <burnus@net-b.de>
 
        PR fortran/87556

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c4df4ebbc408ace58d9d9012a441a5d00fab6c83..ea4cf8cd1b8acd57ed250b1672658cab471d4abb 100644 (file)
--- 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 130e67ba1e446a0aa7c31d231e504ae8e684a564..c778df06329b3ee42aa892d3cbdfcbe9768dde3a 100644 (file)
--- 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 37a9ed3f5b7b7c26e0a3333783823d3eaa11e843..59bada061f446fd1fa513e556d0649c1068371fb 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-10-16  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/67125
+       * gfortran.dg/allocate_with_source_26.f90: New.
+
 2018-10-15  David Malcolm  <dmalcolm@redhat.com>
 
        * 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 (file)
index 0000000..38127c0
--- /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