re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec)

gcc/testsuite/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.dg/allocate_with_source_3.f90: Removed check for
	unimplemented error.
	* gfortran.dg/allocate_with_source_7.f08: New test.
	* gfortran.dg/allocate_with_source_8.f08: New test.

gcc/fortran/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.h: Extend gfc_code.ext.alloc to carry a
	flag indicating that the array specification has to be
	taken from expr3.
	* resolve.c (resolve_allocate_expr): Add F2008 notify
	and flag indicating source driven array spec.
	(resolve_allocate_deallocate): Check for source driven
	array spec, when array to allocate has no explicit
	array spec.
	* trans-array.c (gfc_array_init_size): Get lower and
	upper bound from a tree array descriptor, except when
	the source expression is an array-constructor which is
	fixed to be one-based.
	(retrieve_last_ref): Extracted from gfc_array_allocate().
	(gfc_array_allocate): Enable allocate(array, source= 
	array_expression) as specified by F2008:C633.
	(gfc_conv_expr_descriptor): Add class tree expression
	into the saved descriptor for class arrays.
	* trans-array.h: Add temporary array descriptor to
	gfc_array_allocate ().
	* trans-expr.c (gfc_conv_procedure_call): Special handling
	for _copy() routine translation, that comes without an
	interface. Third and fourth argument are now passed by value.
	* trans-stmt.c (gfc_trans_allocate): Get expr3 array
	descriptor for temporary arrays to allow allocate(array,
	source = array_expression) for array without array
	specification.

From-SVN: r224477

1 files changed, 100 insertions, 19 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5ea9aec..e9174ae 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4998,7 +4998,8 @@ static tree
 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_elem_size, tree *nelems, gfc_expr *expr3,
+		     tree expr3_desc, bool e3_is_array_constr)
 {
   tree type;
   tree tmp;
@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set lower bound.  */
       gfc_init_se (&se, NULL);
-      if (lower == 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.  */
+	    se.expr = gfc_index_one_node;
+	  else
+	    se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else if (lower == NULL)
 	se.expr = gfc_index_one_node;
       else
 	{
@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set upper bound.  */
       gfc_init_se (&se, NULL);
-      gcc_assert (ubound);
-      gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
-      gfc_add_block_to_block (pblock, &se.pre);
-
+      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.  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 (
+				       expr3_desc, gfc_rank_cst[n]),
+				     gfc_conv_descriptor_lbound_get (
+				       expr3_desc, gfc_rank_cst[n]));
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_one_node);
+	      se.expr = gfc_evaluate_now (tmp, pblock);
+	    }
+	  else
+	    se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
+						      gfc_rank_cst[n]);
+	}
+      else
+	{
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	}
       gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], se.expr);
       conv_ubound = se.expr;
@@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 }
 
 
+/* Retrieve the last ref from the chain.  This routine is specific to
+   gfc_array_allocate ()'s needs.  */
+
+bool
+retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
+{
+  gfc_ref *ref, *prev_ref;
+
+  ref = *ref_in;
+  /* Prevent warnings for uninitialized variables.  */
+  prev_ref = *prev_ref_in;
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+      prev_ref = ref;
+      ref = ref->next;
+    }
+
+  if (ref == NULL || ref->type != REF_ARRAY)
+    return false;
+
+  *ref_in = ref;
+  *prev_ref_in = prev_ref;
+  return true;
+}
+
 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
    the work for an ALLOCATE statement.  */
 /*GCC ARRAYS*/
@@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 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 *nelems, gfc_expr *expr3, tree e3_arr_desc,
+		    bool e3_is_array_constr)
 {
   tree tmp;
   tree pointer;
@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_expr **lower;
   gfc_expr **upper;
   gfc_ref *ref, *prev_ref = NULL;
-  bool allocatable, coarray, dimension;
+  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
 
   ref = expr->ref;
 
   /* Find the last reference in the chain.  */
-  while (ref && ref->next != NULL)
+  if (!retrieve_last_ref (&ref, &prev_ref))
+    return false;
+
+  if (ref->u.ar.type == AR_FULL && expr3 != NULL)
     {
-      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
-		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
-      prev_ref = ref;
-      ref = ref->next;
-    }
+      /* F08:C633: Array shape from expr3.  */
+      ref = expr3->ref;
 
-  if (ref == NULL || ref->type != REF_ARRAY)
-    return false;
+      /* Find the last reference in the chain.  */
+      if (!retrieve_last_ref (&ref, &prev_ref))
+	return false;
+      alloc_w_e3_arr_spec = true;
+    }
 
   if (!prev_ref)
     {
@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
       break;
 
     case AR_FULL:
-      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
+      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+		  || alloc_w_e3_arr_spec);
 
       lower = ref->u.ar.as->lower;
       upper = ref->u.ar.as->upper;
@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   overflow = integer_zero_node;
 
   gfc_init_block (&set_descriptor_block);
-  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+  size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
+							   : ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3);
+			      expr3_elem_size, nelems, expr3, e3_arr_desc,
+			      e3_is_array_constr);
 
   if (dimension)
     {
@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       desc = parm;
     }
 
+  /* For class arrays add the class tree into the saved descriptor to
+     enable getting of _vptr and the like.  */
+  if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
+      && IS_CLASS_ARRAY (expr->symtree->n.sym)
+      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+    {
+      gfc_allocate_lang_decl (desc);
+      GFC_DECL_SAVED_DESCRIPTOR (desc) =
+	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+    }
   if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */