1 files changed, 260 insertions, 30 deletions

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 1561936..990aaaf 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1426,12 +1426,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
 	  tmp2 = gfc_class_len_get (class_expr);
 	  gfc_add_modify (pre, tmp, tmp2);
 	}
-
-      if (rhs_function)
-	{
-	  tmp = gfc_class_data_get (class_expr);
-	  gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
-	}
     }
   else if (rhs_ss->info->data.array.descriptor)
    {
@@ -3372,18 +3366,51 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  break;
 
 	case GFC_SS_FUNCTION:
-	  /* Array function return value.  We call the function and save its
-	     result in a temporary for use inside the loop.  */
-	  gfc_init_se (&se, NULL);
-	  se.loop = loop;
-	  se.ss = ss;
-	  if (gfc_is_class_array_function (expr))
-	    expr->must_finalize = 1;
-	  gfc_conv_expr (&se, expr);
-	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
-	  gfc_add_block_to_block (&outer_loop->post, &se.post);
-	  gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
-	  ss_info->string_length = se.string_length;
+	  {
+	    /* Array function return value.  We call the function and save its
+	       result in a temporary for use inside the loop.  */
+	    gfc_init_se (&se, NULL);
+	    se.loop = loop;
+	    se.ss = ss;
+	    bool class_func = gfc_is_class_array_function (expr);
+	    if (class_func)
+	      expr->must_finalize = 1;
+	    gfc_conv_expr (&se, expr);
+	    gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+	    if (class_func
+		&& se.expr
+		&& GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+	      {
+		tree tmp = gfc_class_data_get (se.expr);
+		info->descriptor = tmp;
+		info->data = gfc_conv_descriptor_data_get (tmp);
+		info->offset = gfc_conv_descriptor_offset_get (tmp);
+		for (gfc_ss *s = ss; s; s = s->parent)
+		  for (int n = 0; n < s->dimen; n++)
+		    {
+		      int dim = s->dim[n];
+		      tree tree_dim = gfc_rank_cst[dim];
+
+		      tree start;
+		      start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
+		      start = gfc_evaluate_now (start, &outer_loop->pre);
+		      info->start[dim] = start;
+
+		      tree end;
+		      end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
+		      end = gfc_evaluate_now (end, &outer_loop->pre);
+		      info->end[dim] = end;
+
+		      tree stride;
+		      stride = gfc_conv_descriptor_stride_get (tmp, tree_dim);
+		      stride = gfc_evaluate_now (stride, &outer_loop->pre);
+		      info->stride[dim] = stride;
+		    }
+	      }
+	    gfc_add_block_to_block (&outer_loop->post, &se.post);
+	    gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
+	    ss_info->string_length = se.string_length;
+	  }
 	  break;
 
 	case GFC_SS_CONSTRUCTOR:
@@ -3437,6 +3464,166 @@ save_descriptor_data (tree descr, tree data)
 }
 
 
+/* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr
+   and used by maybe_substitute_expr.  */
+
+typedef struct
+{
+  tree target, repl;
+}
+substitute_t;
+
+
+/* Check if the expression in *TP is equal to the substitution target provided
+   in DATA->TARGET and replace it with DATA->REPL in that case.   This is a
+   callback function for use with walk_tree.  */
+
+static tree
+maybe_substitute_expr (tree *tp, int *walk_subtree, void *data)
+{
+  substitute_t *subst = (substitute_t *) data;
+  if (*tp == subst->target)
+    {
+      *tp = subst->repl;
+      *walk_subtree = 0;
+    }
+
+  return NULL_TREE;
+}
+
+
+/* Substitute in EXPR any occurence of TARGET with REPLACEMENT.  */
+
+static void
+substitute_subexpr_in_expr (tree target, tree replacement, tree expr)
+{
+  substitute_t subst;
+  subst.target = target;
+  subst.repl = replacement;
+
+  walk_tree (&expr, maybe_substitute_expr, &subst, nullptr);
+}
+
+
+/* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra
+   code to CODE.  Before returning, add REF to REPLACEMENT_ROOTS and clear
+   REF.  */
+
+static void
+save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
+{
+  stmtblock_t tmp_block;
+  gfc_init_block (&tmp_block);
+  tree var = gfc_evaluate_now (ref, &tmp_block);
+  gfc_add_expr_to_block (&tmp_block, code);
+  code = gfc_finish_block (&tmp_block);
+
+  unsigned i;
+  tree repl_root;
+  FOR_EACH_VEC_ELT (replacement_roots, i, repl_root)
+    substitute_subexpr_in_expr (ref, var, repl_root);
+
+  replacement_roots.safe_push (ref);
+  ref = NULL_TREE;
+}
+
+
+/* Save the descriptor reference VALUE to storage pointed by DESC_PTR.  Before
+   that, try to factor subexpressions of VALUE to variables, adding extra code
+   to BLOCK.
+
+   The candidate references to factoring are dereferenced pointers because they
+   are cheap to copy and array descriptors because they are often the base of
+   multiple subreferences.  */
+
+static void
+set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
+{
+  /* As the reference is processed from outer to inner, variable definitions
+     will be generated in reversed order, so can't be put directly in BLOCK.
+     We use TMP_BLOCK instead.  */
+  tree accumulated_code = NULL_TREE;
+
+  /* The current candidate to factoring.  */
+  tree saveable_ref = NULL_TREE;
+
+  /* The root expressions in which we look for subexpressions to replace with
+     variables.  */
+  auto_vec<tree> replacement_roots;
+  replacement_roots.safe_push (value);
+
+  tree data_ref = value;
+  tree next_ref = NULL_TREE;
+
+  /* If the candidate reference is not followed by a subreference, it can't be
+     saved to a variable as it may be reallocatable, and we have to keep the
+     parent reference to be able to store the new pointer value in case of
+     reallocation.  */
+  bool maybe_reallocatable = true;
+
+  while (true)
+    {
+      if (!maybe_reallocatable
+	  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref)))
+	saveable_ref = data_ref;
+
+      if (TREE_CODE (data_ref) == INDIRECT_REF)
+	{
+	  next_ref = TREE_OPERAND (data_ref, 0);
+
+	  if (!maybe_reallocatable)
+	    {
+	      if (saveable_ref != NULL_TREE && saveable_ref != data_ref)
+		{
+		  /* A reference worth saving has been seen, and now the pointer
+		     to the current reference is also worth saving.  If the
+		     previous reference to save wasn't the current one, do save
+		     it now.  Otherwise drop it as we prefer saving the
+		     pointer.  */
+		  save_ref (accumulated_code, saveable_ref, replacement_roots);
+		}
+
+	      /* Don't evaluate the pointer to a variable yet; do it only if the
+		 variable would be significantly more simple than the reference
+		 it replaces.  That is if the reference contains anything
+		 different from NOPs, COMPONENTs and DECLs.  */
+	      saveable_ref = next_ref;
+	    }
+	}
+      else if (TREE_CODE (data_ref) == COMPONENT_REF)
+	{
+	  maybe_reallocatable = false;
+	  next_ref = TREE_OPERAND (data_ref, 0);
+	}
+      else if (TREE_CODE (data_ref) == NOP_EXPR)
+	next_ref = TREE_OPERAND (data_ref, 0);
+      else
+	{
+	  if (DECL_P (data_ref))
+	    break;
+
+	  if (TREE_CODE (data_ref) == ARRAY_REF)
+	    {
+	      maybe_reallocatable = false;
+	      next_ref = TREE_OPERAND (data_ref, 0);
+	    }
+
+	  if (saveable_ref != NULL_TREE)
+	    /* We have seen a reference worth saving.  Do it now.  */
+	    save_ref (accumulated_code, saveable_ref, replacement_roots);
+
+	  if (TREE_CODE (data_ref) != ARRAY_REF)
+	    break;
+	}
+
+      data_ref = next_ref;
+    }
+
+  *desc_ptr = value;
+  gfc_add_expr_to_block (block, accumulated_code);
+}
+
+
 /* Translate expressions for the descriptor and data pointer of a SS.  */
 /*GCC ARRAYS*/
 
@@ -3457,7 +3644,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
   se.descriptor_only = 1;
   gfc_conv_expr_lhs (&se, ss_info->expr);
   gfc_add_block_to_block (block, &se.pre);
-  info->descriptor = se.expr;
+  set_factored_descriptor_value (&info->descriptor, se.expr, block);
   ss_info->string_length = se.string_length;
   ss_info->class_container = se.class_container;
 
@@ -5223,7 +5410,8 @@ done:
 	      int dim = ss->dim[n];
 
 	      info->start[dim]  = gfc_index_zero_node;
-	      info->end[dim]    = gfc_index_zero_node;
+	      if (ss_info->type != GFC_SS_FUNCTION)
+		info->end[dim]    = gfc_index_zero_node;
 	      info->stride[dim] = gfc_index_one_node;
 	    }
 	  break;
@@ -5908,6 +6096,46 @@ set_loop_bounds (gfc_loopinfo *loop)
 }
 
 
+/* Last attempt to set the loop bounds, in case they depend on an allocatable
+   function result.  */
+
+static void
+late_set_loop_bounds (gfc_loopinfo *loop)
+{
+  int n, dim;
+  gfc_array_info *info;
+  gfc_ss **loopspec;
+
+  loopspec = loop->specloop;
+
+  for (n = 0; n < loop->dimen; n++)
+    {
+      /* Set the extents of this range.  */
+      if (loop->from[n] == NULL_TREE
+	  || loop->to[n] == NULL_TREE)
+	{
+	  /* We should have found the scalarization loop specifier.  If not,
+	     that's bad news.  */
+	  gcc_assert (loopspec[n]);
+
+	  info = &loopspec[n]->info->data.array;
+	  dim = loopspec[n]->dim[n];
+
+	  if (loopspec[n]->info->type == GFC_SS_FUNCTION
+	      && info->start[dim]
+	      && info->end[dim])
+	    {
+	      loop->from[n] = info->start[dim];
+	      loop->to[n] = info->end[dim];
+	    }
+	}
+    }
+
+  for (loop = loop->nested; loop; loop = loop->next)
+    late_set_loop_bounds (loop);
+}
+
+
 /* Initialize the scalarization loop.  Creates the loop variables.  Determines
    the range of the loop variables.  Creates a temporary if required.
    Also generates code for scalar expressions which have been
@@ -5926,6 +6154,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
      allocating the temporary.  */
   gfc_add_loop_ss_code (loop, loop->ss, false, where);
 
+  late_set_loop_bounds (loop);
+
   tmp_ss = loop->temp_ss;
   /* If we want a temporary then create it.  */
   if (tmp_ss != NULL)
@@ -5982,9 +6212,11 @@ gfc_set_delta (gfc_loopinfo *loop)
       gfc_ss_type ss_type;
 
       ss_type = ss->info->type;
-      if (ss_type != GFC_SS_SECTION
-	  && ss_type != GFC_SS_COMPONENT
-	  && ss_type != GFC_SS_CONSTRUCTOR)
+      if (!(ss_type == GFC_SS_SECTION
+	    || ss_type == GFC_SS_COMPONENT
+	    || ss_type == GFC_SS_CONSTRUCTOR
+	    || (ss_type == GFC_SS_FUNCTION
+		&& gfc_is_class_array_function (ss->info->expr))))
 	continue;
 
       info = &ss->info->data.array;
@@ -6136,8 +6368,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_desc, bool e3_has_nodescriptor, gfc_expr *expr,
+		     tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
+		     bool e3_has_nodescriptor, gfc_expr *expr,
 		     tree *element_size, bool explicit_ts)
 {
   tree type;
@@ -6413,7 +6645,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   if (rank == 0)
     return *element_size;
 
-  *nelems = gfc_evaluate_now (stride, pblock);
   stride = fold_convert (size_type_node, stride);
 
   /* First check for overflow. Since an array of type character can
@@ -6502,9 +6733,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
 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_has_nodescriptor, gfc_omp_namelist *omp_alloc,
-		    bool explicit_ts)
+		    gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
+		    gfc_omp_namelist *omp_alloc, bool explicit_ts)
 {
   tree tmp;
   tree pointer;
@@ -6635,7 +6865,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 			      coarray ? ref->u.ar.as->corank : 0,
 			      &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3, e3_arr_desc,
+			      expr3_elem_size, expr3, e3_arr_desc,
 			      e3_has_nodescriptor, expr, &element_size,
 			      explicit_ts);