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

5 files changed, 101 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index af57bde..1d9d65c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,15 @@
 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
 	* trans-stmt.c (form_team, change_team, sync_team):
 	Don't ignore argse.pre/argse.post.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c4df4eb..ea4cf8c 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 130e67b..c778df0 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 37a9ed3..59bada0 100644
--- 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
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