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

3 files changed, 38 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.