2015-02-06 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/63205
	* gfortran.h: Add 'must finalize' field to gfc_expr and
	prototypes for gfc_is_alloc_class_scalar_function and for
	gfc_is_alloc_class_array_function.
	* expr.c (gfc_is_alloc_class_scalar_function,
	gfc_is_alloc_class_array_function): New functions.
	* trans-array.c (gfc_add_loop_ss_code): Do not move the
	expression for allocatable class scalar functions outside the
	loop.
	(conv_array_index_offset): Cope with deltas being NULL_TREE.
	(build_class_array_ref): Do not return with allocatable class
	array functions. Add code to pick out the returned class array.
	Dereference if necessary and return if not a class object.
	(gfc_conv_scalarized_array_ref): Cope with offsets being NULL.
	(gfc_walk_function_expr): Return an array ss for the result of
	an allocatable class array function.
	* trans-expr.c (gfc_conv_subref_array_arg): Remove the assert
	that the argument should be a variable. If an allocatable class
	array function, set the offset to zero and skip the write-out
	loop in this case.
	(gfc_conv_procedure_call): Add allocatable class array function
	to the assert. Call gfc_conv_subref_array_arg for allocatable
	class array function arguments with derived type formal arg..
	Add the code for handling allocatable class functions, including
	finalization calls to prevent memory leaks.
	(arrayfunc_assign_needs_temporary): Return if an allocatable
	class array function.
	(gfc_trans_assignment_1): Set must_finalize to rhs expression
	for allocatable class functions. Set scalar_to_array as needed
	for scalar class allocatable functions assigned to an array.
	Nullify the allocatable components corresponding the the lhs
	derived type so that the finalization does not free them.

2015-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/63205
	* gfortran.dg/class_to_type_4.f90: New test


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@220482 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 267 insertions, 19 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 63198c89b7d..36772ab5115 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,16 +1,47 @@
+2015-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/63205
+	* gfortran.h: Add 'must finalize' field to gfc_expr and
+	prototypes for gfc_is_alloc_class_scalar_function and for
+	gfc_is_alloc_class_array_function.
+	* expr.c (gfc_is_alloc_class_scalar_function,
+	gfc_is_alloc_class_array_function): New functions.
+	* trans-array.c (gfc_add_loop_ss_code): Do not move the
+	expression for allocatable class scalar functions outside the
+	loop.
+	(conv_array_index_offset): Cope with deltas being NULL_TREE.
+	(build_class_array_ref): Do not return with allocatable class
+	array functions. Add code to pick out the returned class array.
+	Dereference if necessary and return if not a class object.
+	(gfc_conv_scalarized_array_ref): Cope with offsets being NULL.
+	(gfc_walk_function_expr): Return an array ss for the result of
+	an allocatable class array function.
+	* trans-expr.c (gfc_conv_subref_array_arg): Remove the assert
+	that the argument should be a variable. If an allocatable class
+	array function, set the offset to zero and skip the write-out
+	loop in this case.
+	(gfc_conv_procedure_call): Add allocatable class array function
+	to the assert. Call gfc_conv_subref_array_arg for allocatable
+	class array function arguments with derived type formal arg..
+	Add the code for handling allocatable class functions, including
+	finalization calls to prevent memory leaks.
+	(arrayfunc_assign_needs_temporary): Return if an allocatable
+	class array function.
+	(gfc_trans_assignment_1): Set must_finalize to rhs expression
+	for allocatable class functions. Set scalar_to_array as needed
+	for scalar class allocatable functions assigned to an array.
+	Nullify the allocatable components corresponding the the lhs
+	derived type so that the finalization does not free them.
 
-2015-01-29  Andre Vehreschild  <vehre@gmx.de>, Janus Weil  <janus@gcc.gnu.org>
+2015-01-29  Andre Vehreschild  <vehre@gmx.de>
+	    Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/60289
 	Initial patch by Janus Weil
-	* resolve.c (resolve_allocate_expr): Add check for comp. only when 
-	target is not unlimited polymorphic.
-	* trans-stmt.c (gfc_trans_allocate): Assign correct value to _len
-	component of unlimited polymorphic entities.
-
-2015-01-29  Andre Vehreschild  <vehre@gmx.de>
-
-	* gfortran.dg/unlimited_polymorphic_22.f90: New test.
+	* resolve.c (resolve_allocate_expr): Add check for comp. only
+	when target is not unlimited polymorphic.
+	* trans-stmt.c (gfc_trans_allocate): Assign correct value to
+	_len component of unlimited polymorphic entities.
 
 2015-02-05  Tobias Burnus  <burnus@net-b.de>
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index e1fc1d07ee2..ab6f7a52205 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4304,6 +4304,40 @@ gfc_is_proc_ptr_comp (gfc_expr *expr)
 }
 
 
+/* Determine if an expression is a function with an allocatable class scalar
+   result.  */
+bool
+gfc_is_alloc_class_scalar_function (gfc_expr *expr)
+{
+  if (expr->expr_type == EXPR_FUNCTION
+      && expr->value.function.esym
+      && expr->value.function.esym->result
+      && expr->value.function.esym->result->ts.type == BT_CLASS
+      && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension
+      && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+    return true;
+
+  return false;
+}
+
+
+/* Determine if an expression is a function with an allocatable class array
+   result.  */
+bool
+gfc_is_alloc_class_array_function (gfc_expr *expr)
+{
+  if (expr->expr_type == EXPR_FUNCTION
+      && expr->value.function.esym
+      && expr->value.function.esym->result
+      && expr->value.function.esym->result->ts.type == BT_CLASS
+      && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
+      && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+    return true;
+
+  return false;
+}
+
+
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
    mode as is a basic arithmetic expression using those; this is for things in
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6b9f7dd02a6..ff0054e7029 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1969,6 +1969,9 @@ typedef struct gfc_expr
   /* Mark an expression as being a MOLD argument of ALLOCATE.  */
   unsigned int mold : 1;
 
+  /* Will require finalization after use.  */
+  unsigned int must_finalize : 1;
+
   /* If an expression comes from a Hollerith constant or compile-time
      evaluation of a transfer statement, it may have a prescribed target-
      memory representation, and these cannot always be backformed from
@@ -2988,6 +2991,8 @@ bool gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 
 gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
 bool gfc_is_proc_ptr_comp (gfc_expr *);
+bool gfc_is_alloc_class_scalar_function (gfc_expr *);
+bool gfc_is_alloc_class_array_function (gfc_expr *);
 
 bool gfc_ref_this_image (gfc_ref *ref);
 bool gfc_is_coindexed (gfc_expr *);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 08b020b42a8..642110dc41f 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2474,7 +2474,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  gfc_conv_expr (&se, expr);
 	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
 
-	  if (expr->ts.type != BT_CHARACTER)
+	  if (expr->ts.type != BT_CHARACTER
+	      && !gfc_is_alloc_class_scalar_function (expr))
 	    {
 	      /* Move the evaluation of scalar expressions outside the
 		 scalarization loop, except for WHERE assignments.  */
@@ -2955,7 +2956,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
 	stride = gfc_conv_descriptor_stride_get (info->descriptor,
 						 gfc_rank_cst[dim]);
 
-      if (!integer_zerop (info->delta[dim]))
+      if (info->delta[dim] && !integer_zerop (info->delta[dim]))
 	index = fold_build2_loc (input_location, PLUS_EXPR,
 				 gfc_array_index_type, index, info->delta[dim]);
     }
@@ -2984,7 +2985,9 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
   gfc_ref *class_ref;
   gfc_typespec *ts;
 
-  if (expr == NULL || expr->ts.type != BT_CLASS)
+  if (expr == NULL
+      || (expr->ts.type != BT_CLASS
+	  && !gfc_is_alloc_class_array_function (expr)))
     return false;
 
   if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
@@ -3018,6 +3021,30 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
       gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
       decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
     }
+  else if (gfc_is_alloc_class_array_function (expr))
+    {
+      size = NULL_TREE;
+      decl = NULL_TREE;
+      for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
+	{
+	  tree type;
+	  type = TREE_TYPE (tmp);
+	  while (type)
+	    {
+	      if (GFC_CLASS_TYPE_P (type))
+		decl = tmp;
+	      if (type != TYPE_CANONICAL (type))
+		type = TYPE_CANONICAL (type);
+	      else
+		type = NULL_TREE;
+	    }
+	  if (TREE_CODE (tmp) == VAR_DECL)
+	    break;
+	}
+
+      if (decl == NULL_TREE)
+	return false;
+    }
   else if (class_ref == NULL)
     decl = expr->symtree->n.sym->backend_decl;
   else
@@ -3033,6 +3060,12 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
       class_ref->next = ref;
     }
 
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+
+  if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+    return false;
+
   size = gfc_vtable_size_get (decl);
 
   /* Build the address of the element.  */
@@ -3075,7 +3108,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
   index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
   /* Add the offset for this dimension to the stored offset for all other
      dimensions.  */
-  if (!integer_zerop (info->offset))
+  if (info->offset && !integer_zerop (info->offset))
     index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 			     index, info->offset);
 
@@ -9049,6 +9082,11 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
   if (!sym)
     sym = expr->symtree->n.sym;
 
+  if (gfc_is_alloc_class_array_function (expr))
+    return gfc_get_array_ss (ss, expr,
+			     CLASS_DATA (expr->value.function.esym->result)->as->rank,
+			     GFC_SS_FUNCTION);
+
   /* A function that returns arrays.  */
   comp = gfc_get_proc_ptr_comp (expr);
   if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1af3696a922..d6f84ff04de 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3875,8 +3875,6 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   int n;
   int dimen;
 
-  gcc_assert (expr->expr_type == EXPR_VARIABLE);
-
   gfc_init_se (&lse, NULL);
   gfc_init_se (&rse, NULL);
 
@@ -3936,6 +3934,16 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   /* Translate the expression.  */
   gfc_conv_expr (&rse, expr);
 
+  /* Reset the offset for the function call since the loop
+     is zero based on the data pointer.  Note that the temp
+     comes first in the loop chain since it is added second.  */
+  if (gfc_is_alloc_class_array_function (expr))
+    {
+      tmp = loop.ss->loop_chain->info->data.array.descriptor;
+      gfc_conv_descriptor_offset_set (&loop.pre, tmp,
+				      gfc_index_zero_node);
+    }
+
   gfc_conv_tmp_array_ref (&lse);
 
   if (intent != INTENT_OUT)
@@ -3975,6 +3983,12 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   gfc_init_loopinfo (&loop2);
   gfc_add_ss_to_loop (&loop2, lss);
 
+  dimen = rse.ss->dimen;
+
+  /* Skip the write-out loop for this case.  */
+  if (gfc_is_alloc_class_array_function (expr))
+    goto class_array_fcn;
+
   /* Calculate the bounds of the scalarization.  */
   gfc_conv_ss_startstride (&loop2);
 
@@ -3998,7 +4012,6 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
      outside the innermost loop, so the overall transfer could be
      optimized further.  */
   info = &rse.ss->info->data.array;
-  dimen = rse.ss->dimen;
 
   tmp_index = gfc_index_zero_node;
   for (n = dimen - 1; n > 0; n--)
@@ -4057,6 +4070,8 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
       gfc_add_block_to_block (&parmse->post, &loop2.post);
     }
 
+class_array_fcn:
+
   gfc_add_block_to_block (&parmse->post, &loop.post);
 
   gfc_cleanup_loop (&loop);
@@ -4199,9 +4214,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    {
 	      gcc_assert ((!comp && gfc_return_by_reference (sym)
 			   && sym->result->attr.dimension)
-			  || (comp && comp->attr.dimension));
+			  || (comp && comp->attr.dimension)
+			  || gfc_is_alloc_class_array_function (expr));
 	      gcc_assert (se->loop != NULL);
-
 	      /* Access the previously obtained result.  */
 	      gfc_conv_tmp_array_ref (se);
 	      return 0;
@@ -4839,6 +4854,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		gfc_conv_subref_array_arg (&parmse, e, f,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
+
+	      else if (gfc_is_alloc_class_array_function (e)
+			 && fsym && fsym->ts.type == BT_DERIVED)
+		/* See previous comment.  For function actual argument,
+		   the write out is not needed so the intent is set as
+		   intent in.  */
+		{
+		  e->must_finalize = 1;
+		  gfc_conv_subref_array_arg (&parmse, e, f,
+					     INTENT_IN,
+					     fsym && fsym->attr.pointer);
+		}
 	      else
 	        gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
 
@@ -5576,7 +5603,80 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	}
     }
   else
-    gfc_add_block_to_block (&se->post, &post);
+    {
+      /* For a function with a class array result, save the result as
+	 a temporary, set the info fields needed by the scalarizer and
+	 call the finalization function of the temporary. Note that the
+	 nullification of allocatable components needed by the result
+	 is done in gfc_trans_assignment_1.  */
+      if (expr && ((gfc_is_alloc_class_array_function (expr)
+		    && se->ss && se->ss->loop)
+		   || gfc_is_alloc_class_scalar_function (expr))
+	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
+	  && expr->must_finalize)
+	{
+	  tree final_fndecl;
+	  tree is_final;
+	  int n;
+	  if (se->ss && se->ss->loop)
+	    {
+	      se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
+	      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 (n = 0; n < se->ss->loop->dimen; n++)
+		{
+		  tree dim = gfc_rank_cst[n];
+		  se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
+		  se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
+		}
+	    }
+	  else
+	    {
+	      /* TODO Eliminate the doubling of temporaries. This
+		 one is necessary to ensure no memory leakage.  */
+	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
+	      tmp = gfc_class_data_get (se->expr);
+	      tmp = gfc_conv_scalar_to_descriptor (se, tmp,
+			CLASS_DATA (expr->value.function.esym->result)->attr);
+	    }
+
+	  final_fndecl = gfc_vtable_final_get (se->expr);
+	  is_final = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node,
+ 			    	      final_fndecl,
+				      fold_convert (TREE_TYPE (final_fndecl),
+					   	    null_pointer_node));
+	  final_fndecl = build_fold_indirect_ref_loc (input_location,
+						      final_fndecl);
+ 	  tmp = build_call_expr_loc (input_location,
+				     final_fndecl, 3,
+				     gfc_build_addr_expr (NULL, tmp),
+				     gfc_vtable_size_get (se->expr),
+				     boolean_false_node);
+ 	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, is_final, tmp,
+				 build_empty_stmt (input_location));
+
+	  if (se->ss && se->ss->loop)
+	    {
+	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
+	      tmp = gfc_call_free (convert (pvoid_type_node, info->data));
+	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
+	    }
+	  else
+	    {
+	      gfc_add_expr_to_block (&se->post, tmp);
+	      tmp = gfc_class_data_get (se->expr);
+	      tmp = gfc_call_free (convert (pvoid_type_node, tmp));
+	      gfc_add_expr_to_block (&se->post, tmp);
+	    }
+	  expr->must_finalize = 0;
+	}
+
+      gfc_add_block_to_block (&se->post, &post);
+    }
 
   return has_alternate_specifier;
 }
@@ -7661,6 +7761,11 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
   bool c = false;
   gfc_symbol *sym = expr1->symtree->n.sym;
 
+  /* Play it safe with class functions assigned to a derived type.  */
+  if (gfc_is_alloc_class_array_function (expr2)
+      && expr1->ts.type == BT_DERIVED)
+    return true;
+
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
     return true;
@@ -8530,6 +8635,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	     && expr2->value.function.isym != NULL))
     lss->is_alloc_lhs = 1;
   rss = NULL;
+
+  if ((expr1->ts.type == BT_DERIVED)
+      && (gfc_is_alloc_class_array_function (expr2)
+	  || gfc_is_alloc_class_scalar_function (expr2)))
+    expr2->must_finalize = 1;
+
   if (lss != gfc_ss_terminator)
     {
       /* The assignment needs scalarization.  */
@@ -8598,6 +8709,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   /* Translate the expression.  */
   gfc_conv_expr (&rse, expr2);
 
+  /* Deal with the case of a scalar class function assigned to a derived type.  */
+  if (gfc_is_alloc_class_scalar_function (expr2)
+      && expr1->ts.type == BT_DERIVED)
+    {
+      rse.expr = gfc_class_data_get (rse.expr);
+      rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
+    }
+
   /* Stabilize a string length for temporaries.  */
   if (expr2->ts.type == BT_CHARACTER)
     string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
@@ -8621,6 +8740,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 		       && !expr_is_variable (expr2)
 		       && !gfc_is_constant_expr (expr2)
 		       && expr1->rank && !expr2->rank);
+  scalar_to_array |= (expr1->ts.type == BT_DERIVED
+				    && expr1->rank
+				    && expr1->ts.u.derived->attr.alloc_comp
+				    && gfc_is_alloc_class_scalar_function (expr2));
   if (scalar_to_array && dealloc)
     {
       tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
@@ -8635,6 +8758,23 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
     gfc_add_block_to_block (&block, &rse.pre);
 
+  /* Nullify the allocatable components corresponding to those of the lhs
+     derived type, so that the finalization of the function result does not
+     affect the lhs of the assignment. Prepend is used to ensure that the
+     nullification occurs before the call to the finalizer. In the case of
+     a scalar to array assignment, this is done in gfc_trans_scalar_assign
+     as part of the deep copy.  */
+  if (!scalar_to_array && (expr1->ts.type == BT_DERIVED)
+					      && (gfc_is_alloc_class_array_function (expr2)
+						      || gfc_is_alloc_class_scalar_function (expr2)))
+    {
+      tmp = rse.expr;
+      tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
+      gfc_prepend_expr_to_block (&rse.post, tmp);
+      if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
+	gfc_add_block_to_block (&loop.post, &rse.post);
+    }
+
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
 				 l_is_temp || init_flag,
 				 expr_is_variable (expr2) || scalar_to_array