[Patch, Fortran] PR67125 - ALLOCATE with source-expr lbounds/ubound off by one

[Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>]

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  <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.

	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