re PR fortran/63205 ([OOP] Wrongly rejects type = class (for identical declared type))

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

From-SVN: r220482

1 files changed, 42 insertions, 4 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 08b020b..642110d 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)