2017-11-19 Paul Thomas <[email protected]>

	PR fortran/78990
	* expr.c (gfc_is_class_array_function): Renamed from
	'gfc_is_alloc_class_array_function' and modified to return true
	for pointers as well as allocatable results.
	* gfortran.h : Change of name for prototype of above function.
	* trans-array.c (gfc_add_loop_ss_code): Force finalization of
	class array results.
	(build_class_array_ref): Change assertion into a condition.
	(build_class_array_ref): Set the se class_vptr for class array
	function results.
	(gfc_walk_function_expr): Reference gfc_is_class_array_function
	as above.
	* trans-decl.c (get_proc_result): Move it up before
	gfc_trans_deferred_vars.
	(gfc_trans_deferred_vars): Nullify explicit return class arrays
	on entry.
	* trans-expr.c (gfc_conv_class_to_class): Allow conversion of
	class array functions that have an se class_vptr and use it
	for the result vptr.
	(gfc_conv_subref_array_arg): Rename reference to the above
	function.
	(gfc_conv_procedure_call): Ditto. Add the se pre block to the
	loop pre block before the function is evaluated. Do not
	finalize class pointer results.
	(arrayfunc_assign_needs_temporary, gfc_trans_assignment_1) More
	renamed references.
	* trans-intrinsic.c (gfc_conv_intrinsic_size): Ditto.

2017-11-19  Paul Thomas  <[email protected]>

	PR fortran/78990
	* gfortran.dg/class_67.f90: New test.



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

Author: pault

gcc/fortran/ChangeLog

@@ -1,3 +1,33 @@
+2017-11-19  Paul Thomas  <[email protected]>
+
+	PR fortran/78990
+	* expr.c (gfc_is_class_array_function): Renamed from
+	'gfc_is_alloc_class_array_function' and modified to return true
+	for pointers as well as allocatable results.
+	* gfortran.h : Change of name for prototype of above function.
+	* trans-array.c (gfc_add_loop_ss_code): Force finalization of
+	class array results.
+	(build_class_array_ref): Change assertion into a condition.
+	(build_class_array_ref): Set the se class_vptr for class array
+	function results.
+	(gfc_walk_function_expr): Reference gfc_is_class_array_function
+	as above.
+	* trans-decl.c (get_proc_result): Move it up before
+	gfc_trans_deferred_vars.
+	(gfc_trans_deferred_vars): Nullify explicit return class arrays
+	on entry.
+	* trans-expr.c (gfc_conv_class_to_class): Allow conversion of
+	class array functions that have an se class_vptr and use it
+	for the result vptr.
+	(gfc_conv_subref_array_arg): Rename reference to the above
+	function.
+	(gfc_conv_procedure_call): Ditto. Add the se pre block to the
+	loop pre block before the function is evaluated. Do not
+	finalize class pointer results.
+	(arrayfunc_assign_needs_temporary, gfc_trans_assignment_1) More
+	renamed references.
+	* trans-intrinsic.c (gfc_conv_intrinsic_size): Ditto.
+
 2017-11-18  Janne Blomqvist  <[email protected]>
 
 	PR fortran/83036

gcc/fortran/expr.c

@@ -4844,14 +4844,15 @@ gfc_is_alloc_class_scalar_function (gfc_expr *expr)
 /* Determine if an expression is a function with an allocatable class array
    result.  */
 bool
-gfc_is_alloc_class_array_function (gfc_expr *expr)
+gfc_is_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)
+      && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
+	  || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
     return true;
 
   return false;

gcc/fortran/gfortran.h

@@ -3195,7 +3195,7 @@ gfc_param_spec_type gfc_spec_list_type (gfc_actual_arglist *, gfc_symbol *);
 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_is_class_array_function (gfc_expr *);
 
 bool gfc_ref_this_image (gfc_ref *ref);
 bool gfc_is_coindexed (gfc_expr *);

gcc/fortran/resolve.c

@@ -8740,6 +8740,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	code->expr1->symtree->n.sym->ts = code->expr2->ts;
       selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
 
+      if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
+	CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
+
       /* F2008: C803 The selector expression must not be coindexed.  */
       if (gfc_is_coindexed (code->expr2))
 	{

gcc/fortran/trans-array.c

@@ -2791,6 +2791,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  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);
@@ -3241,7 +3243,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
     {
       if (expr == NULL
 	  || (expr->ts.type != BT_CLASS
-	      && !gfc_is_alloc_class_array_function (expr)
+	      && !gfc_is_class_array_function (expr)
 	      && !gfc_is_class_array_ref (expr, NULL)))
 	return false;
 
@@ -3271,12 +3273,12 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
     }
 
   if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
-      && expr->symtree->n.sym == expr->symtree->n.sym->result)
+      && expr->symtree->n.sym == expr->symtree->n.sym->result
+      && expr->symtree->n.sym->backend_decl == current_function_decl)
     {
-      gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
       decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
     }
-  else if (expr && gfc_is_alloc_class_array_function (expr))
+  else if (expr && gfc_is_class_array_function (expr))
     {
       size = NULL_TREE;
       decl = NULL_TREE;
@@ -3299,6 +3301,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
 
       if (decl == NULL_TREE)
 	return false;
+
+      se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
     }
   else if (class_ref == NULL)
     {
@@ -10527,7 +10531,7 @@ 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))
+  if (gfc_is_class_array_function (expr))
     return gfc_get_array_ss (ss, expr,
 			     CLASS_DATA (expr->value.function.esym->result)->as->rank,
 			     GFC_SS_FUNCTION);

gcc/fortran/trans-decl.c

@@ -4161,6 +4161,24 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
   return tmp;
 }
 
+
+/* Get the result expression for a procedure.  */
+
+static tree
+get_proc_result (gfc_symbol* sym)
+{
+  if (sym->attr.subroutine || sym == sym->result)
+    {
+      if (current_fake_result_decl != NULL)
+	return TREE_VALUE (current_fake_result_decl);
+
+      return NULL_TREE;
+    }
+
+  return sym->result->backend_decl;
+}
+
+
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
     Allocation and initialization of array variables.
@@ -4271,6 +4289,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
       else
 	gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
     }
+  else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
+    {
+      /* Nullify explicit return class arrays on entry.  */
+      tree type;
+      tmp = get_proc_result (proc_sym);
+	if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+	  {
+	    gfc_start_block (&init);
+	    tmp = gfc_class_data_get (tmp);
+	    type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
+	    gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
+	    gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+	  }
+    }
+
 
   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
      should be done here so that the offsets and lbounds of arrays
@@ -6067,23 +6100,6 @@ create_main_function (tree fndecl)
 }
 
 
-/* Get the result expression for a procedure.  */
-
-static tree
-get_proc_result (gfc_symbol* sym)
-{
-  if (sym->attr.subroutine || sym == sym->result)
-    {
-      if (current_fake_result_decl != NULL)
-	return TREE_VALUE (current_fake_result_decl);
-
-      return NULL_TREE;
-    }
-
-  return sym->result->backend_decl;
-}
-
-
 /* Generate an appropriate return-statement for a procedure.  */
 
 tree

gcc/fortran/trans-expr.c

@@ -960,6 +960,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
     }
 
   if ((ref == NULL || class_ref == ref)
+      && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
       && (!class_ts.u.derived->components->as
 	  || class_ts.u.derived->components->as->rank != -1))
     return;
@@ -1030,8 +1031,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
      First we have to find the corresponding class reference.  */
 
   tmp = NULL_TREE;
-  if (class_ref == NULL
-	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+  if (gfc_is_class_array_function (e)
+      && parmse->class_vptr != NULL_TREE)
+    tmp = parmse->class_vptr;
+  else if (class_ref == NULL
+	   && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       tmp = e->symtree->n.sym->backend_decl;
 
@@ -1063,7 +1067,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
   if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
     tmp = build_fold_indirect_ref_loc (input_location, tmp);
 
-  vptr = gfc_class_vptr_get (tmp);
+  if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
+    vptr = gfc_class_vptr_get (tmp);
+  else
+    vptr = tmp;
+
   gfc_add_modify (&block, ctree,
 		  fold_convert (TREE_TYPE (ctree), vptr));
 
@@ -4435,7 +4443,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   /* 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))
+  if (gfc_is_class_array_function (expr))
     {
       tmp = loop.ss->loop_chain->info->data.array.descriptor;
       gfc_conv_descriptor_offset_set (&loop.pre, tmp,
@@ -4484,7 +4492,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   dimen = rse.ss->dimen;
 
   /* Skip the write-out loop for this case.  */
-  if (gfc_is_alloc_class_array_function (expr))
+  if (gfc_is_class_array_function (expr))
     goto class_array_fcn;
 
   /* Calculate the bounds of the scalarization.  */
@@ -4778,7 +4786,7 @@ 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)
-			  || gfc_is_alloc_class_array_function (expr));
+			  || gfc_is_class_array_function (expr));
 	      gcc_assert (se->loop != NULL);
 	      /* Access the previously obtained result.  */
 	      gfc_conv_tmp_array_ref (se);
@@ -5462,7 +5470,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
 
-	      else if (gfc_is_alloc_class_array_function (e)
+	      else if (gfc_is_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
@@ -6304,7 +6312,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	 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)
+      if (expr && ((gfc_is_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))
@@ -6315,6 +6323,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  int n;
 	  if (se->ss && se->ss->loop)
 	    {
+	      gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
 	      se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
 	      tmp = gfc_class_data_get (se->expr);
 	      info->descriptor = tmp;
@@ -6337,6 +6346,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }
 
+	  if ((gfc_is_class_array_function (expr)
+	       || gfc_is_alloc_class_scalar_function (expr))
+	      && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
+	    goto no_finalization;
+
 	  final_fndecl = gfc_class_vtab_final_get (se->expr);
 	  is_final = fold_build2_loc (input_location, NE_EXPR,
 				      logical_type_node,
@@ -6367,6 +6381,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tmp = gfc_call_free (tmp);
 	      gfc_add_expr_to_block (&se->post, tmp);
 	    }
+
+no_finalization:
 	  expr->must_finalize = 0;
 	}
 
@@ -8887,7 +8903,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
   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)
+  if (gfc_is_class_array_function (expr2)
       && expr1->ts.type == BT_DERIVED)
     return true;
 
@@ -9894,7 +9910,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   rss = NULL;
 
   if ((expr1->ts.type == BT_DERIVED)
-      && (gfc_is_alloc_class_array_function (expr2)
+      && (gfc_is_class_array_function (expr2)
 	  || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;
 
@@ -10101,7 +10117,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      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_class_array_function (expr2)
 			   || gfc_is_alloc_class_scalar_function (expr2)))
     {
       tmp = rse.expr;

gcc/fortran/trans-intrinsic.c

@@ -6603,7 +6603,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
     gfc_add_class_array_ref (actual->expr);
 
   argse.data_not_needed = 1;
-  if (gfc_is_alloc_class_array_function (actual->expr))
+  if (gfc_is_class_array_function (actual->expr))
     {
       /* For functions that return a class array conv_expr_descriptor is not
 	 able to get the descriptor right.  Therefore this special case.  */

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2017-11-19  Paul Thomas  <[email protected]>
+
+	PR fortran/78990
+	* gfortran.dg/class_67.f90: New test.
+
 2017-11-19  Jan Hubicka  <[email protected]>
 
 	PR target/82713
@@ -270,7 +275,7 @@
 	* g++.dg/torture/pr82985.C: Likewise.
 
 2017-11-15  Sebastian Peryt  <[email protected]>
-	
+
 	PR target/82941
 	PR target/82942
 	* gcc.target/i386/pr82941-1.c: New test.