re PR fortran/69566 ([OOP] Failure of SELECT TYPE with unlimited polymorphic function result)

2016-10-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69566
	* resolve.c (fixup_array_ref): New function.
	(resolve_select_type): Gather up the rank and array reference,
	if any, from the selector. Fix up the 'associate name' and the
	'associate entities' as necessary.
	* trans-expr.c (gfc_conv_class_to_class): If the symbol backend
	decl is a FUNCTION_DECL, use the 'fake_result_decl' instead.

2016-10-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69566
	* gfortran.dg/select_type_37.f03: New test.

From-SVN: r241403

gcc/fortran/ChangeLog

+2016-10-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/69566
+	* resolve.c (fixup_array_ref): New function.
+	(resolve_select_type): Gather up the rank and array reference,
+	if any, from the selector. Fix up the 'associate name' and the
+	'associate entities' as necessary.
+	* trans-expr.c (gfc_conv_class_to_class): If the symbol backend
+	decl is a FUNCTION_DECL, use the 'fake_result_decl' instead.
+
 2016-10-20  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* array.c (gfc_match_array_constructor): Remove set, but unused

gcc/fortran/resolve.c

@@ -8327,6 +8327,48 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 }
 
 
+/* Ensure that SELECT TYPE expressions have the correct rank and a full
+   array reference, where necessary.  The symbols are artificial and so
+   the dimension attribute and arrayspec can also be set.  In addition,
+   sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS.
+   This is corrected here as well.*/
+
+static void
+fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
+		 int rank, gfc_ref *ref)
+{
+  gfc_ref *nref = (*expr1)->ref;
+  gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
+  gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL;
+  (*expr1)->rank = rank;
+  if (sym1->ts.type == BT_CLASS)
+    {
+      if ((*expr1)->ts.type != BT_CLASS)
+	(*expr1)->ts = sym1->ts;
+
+      CLASS_DATA (sym1)->attr.dimension = 1;
+      if (CLASS_DATA (sym1)->as == NULL && sym2)
+	CLASS_DATA (sym1)->as
+		= gfc_copy_array_spec (CLASS_DATA (sym2)->as);
+    }
+  else
+    {
+      sym1->attr.dimension = 1;
+      if (sym1->as == NULL && sym2)
+	sym1->as = gfc_copy_array_spec (sym2->as);
+    }
+
+  for (; nref; nref = nref->next)
+    if (nref->next == NULL)
+      break;
+
+  if (ref && nref && nref->type != REF_ARRAY)
+    nref->next = gfc_copy_ref (ref);
+  else if (ref && !nref)
+    (*expr1)->ref = gfc_copy_ref (ref);
+}
+
+
 /* Resolve a SELECT TYPE statement.  */
 
 static void
@@ -8341,6 +8383,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   gfc_namespace *ns;
   int error = 0;
   int charlen = 0;
+  int rank = 0;
+  gfc_ref* ref = NULL;
 
   ns = code->ext.block.ns;
   gfc_resolve (ns);
@@ -8468,6 +8512,31 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   else
     code->ext.block.assoc = NULL;
 
+  /* Ensure that the selector rank and arrayspec are available to
+     correct expressions in which they might be missing.  */
+  if (code->expr2 && code->expr2->rank)
+    {
+      rank = code->expr2->rank;
+      for (ref = code->expr2->ref; ref; ref = ref->next)
+	if (ref->next == NULL)
+	  break;
+      if (ref && ref->type == REF_ARRAY)
+	ref = gfc_copy_ref (ref);
+
+      /* Fixup expr1 if necessary.  */
+      if (rank)
+	fixup_array_ref (&code->expr1, code->expr2, rank, ref);
+    }
+  else if (code->expr1->rank)
+    {
+      rank = code->expr1->rank;
+      for (ref = code->expr1->ref; ref; ref = ref->next)
+	if (ref->next == NULL)
+	  break;
+      if (ref && ref->type == REF_ARRAY)
+	ref = gfc_copy_ref (ref);
+    }
+
   /* Add EXEC_SELECT to switch on type.  */
   new_st = gfc_get_code (code->op);
   new_st->expr1 = code->expr1;
@@ -8533,7 +8602,12 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
       st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
       st->n.sym->assoc->target->where = code->expr1->where;
       if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN)
-	gfc_add_data_component (st->n.sym->assoc->target);
+	{
+	  gfc_add_data_component (st->n.sym->assoc->target);
+	  /* Fixup the target expression if necessary.  */
+	  if (rank)
+	    fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref);
+	}
 
       new_st = gfc_get_code (EXEC_BLOCK);
       new_st->ext.block.ns = gfc_build_block_ns (ns);
@@ -8672,6 +8746,9 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
   gfc_resolve_blocks (code->block, gfc_current_ns);
   gfc_current_ns = old_ns;
 
+  if (ref)
+    free (ref);
+
   resolve_select (code, true);
 }
 

gcc/fortran/trans-expr.c

@@ -1033,8 +1033,13 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       tmp = e->symtree->n.sym->backend_decl;
+
+      if (TREE_CODE (tmp) == FUNCTION_DECL)
+	tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+
       if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
 	tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
       slen = integer_zero_node;
     }
   else

gcc/testsuite/ChangeLog

+2016-10-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/69566
+	* gfortran.dg/select_type_37.f03: New test.
+
 2016-10-21  Senthil Kumar Selvaraj  <senthil_kumar.selvaraj@atmel.com>
 
 	PR target/71627

gcc/testsuite/gfortran.dg/select_type_37.f03

+! { dg-do run }
+!
+! Checks the fix for PR69556 in which using implicit function results
+! in SELECT TYPE caused all sorts of problems, especially in the form
+! in 'return_pointer1' with "associate_name => selector". The original
+! PR is encapsulated in 'return_pointer'. Explicit results, such as in
+! 'return_pointer2' always worked.
+!
+! Contributed by James Greenhalgh  <jgreenhalgh@gcc.gnu.org>
+!
+program pr69556
+  class(*), pointer :: ptr(:)
+  character(40) :: buffer1, buffer2
+  real :: cst1(2) = [1.0, 2.0]
+  real :: cst2(2) = [3.0, 4.0]
+  real :: cst3(2) = [5.0, 6.0]
+
+  write (buffer1, *) cst1
+  if (.not.associated(return_pointer1(cst1))) call abort
+  if (trim (buffer1) .ne. trim (buffer2)) call abort
+  select type (ptr)
+    type is (real)
+      if (any (ptr .ne. cst2)) call abort
+  end select
+  deallocate (ptr)
+
+  write (buffer1, *) cst2
+  if (.not.associated(return_pointer(cst2))) call abort
+  if (trim (buffer1) .ne. trim (buffer2)) call abort
+  select type (ptr)
+    type is (real)
+      if (any (ptr .ne. cst3)) call abort
+  end select
+  deallocate (ptr)
+
+  write (buffer1, *) cst1
+  if (.not.associated(return_pointer2(cst1))) call abort
+  if (trim (buffer1) .ne. trim (buffer2)) call abort
+  select type (ptr)
+    type is (real)
+      if (any (ptr .ne. cst2)) call abort
+  end select
+  deallocate (ptr)
+
+contains
+
+  function return_pointer2(arg) result (res) ! Explicit result always worked.
+    class(*), pointer :: res(:)
+    real, intent(inout) :: arg(:)
+    allocate (res, source = arg)
+    ptr => res                               ! Check association and cleanup
+    select type (z => res)
+      type is (real(4))
+        write (buffer2, *) z                 ! Check associate expression is OK.
+        z = cst2                             ! Check associate is OK for lvalue.
+    end select
+  end function
+
+  function return_pointer1(arg)
+    class(*), pointer :: return_pointer1(:)
+    real, intent(inout) :: arg(:)
+    allocate (return_pointer1, source = arg)
+    ptr => return_pointer1
+    select type (z => return_pointer1) ! This caused a segfault in compilation.
+      type is (real(4))
+        write (buffer2, *) z
+        z = cst2
+    end select
+  end function
+
+  function return_pointer(arg) ! The form in the PR.
+    class(*), pointer :: return_pointer(:)
+    real, intent(inout) :: arg(:)
+    allocate (return_pointer, source = cst2)
+    ptr => return_pointer
+    select type (return_pointer)
+      type is (real(4)) ! Associate-name ‘__tmp_REAL_4’ at (1) is used as array
+        write (buffer2, *) return_pointer
+        return_pointer = cst3
+    end select
+  end function
+end program
+