re PR fortran/87566 (ICE with class(*) and select)

2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/87566
	* resolve.c (resolve_assoc_var): Add missing array spec for
	class associate names.
	(resolve_select_type): Handle case where last typed component
	of the selector has a different type to the expression.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
	call to gfc_expr_to_initialize with call to gfc_copy_expr.
	(gfc_conv_class_to_class): Guard assignment to 'len' field
	against case where zero constant is supplied.

2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/87566
	* gfortran.dg/select_type_44.f90: New test.
	* gfortran.dg/associate_42.f90: New test.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r265171

gcc/fortran/ChangeLog

+2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/87566
+	* resolve.c (resolve_assoc_var): Add missing array spec for
+	class associate names.
+	(resolve_select_type): Handle case where last typed component
+	of the selector has a different type to the expression.
+	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
+	call to gfc_expr_to_initialize with call to gfc_copy_expr.
+	(gfc_conv_class_to_class): Guard assignment to 'len' field
+	against case where zero constant is supplied.
+
 2018-10-12  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/87597

gcc/fortran/resolve.c

@@ -8675,6 +8675,18 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	  if (as->corank != 0)
 	    sym->attr.codimension = 1;
 	}
+      else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+	{
+	  if (!CLASS_DATA (sym)->as)
+	    CLASS_DATA (sym)->as = gfc_get_array_spec ();
+	  as = CLASS_DATA (sym)->as;
+	  as->rank = target->rank;
+	  as->type = AS_DEFERRED;
+	  as->corank = gfc_get_corank (target);
+	  CLASS_DATA (sym)->attr.dimension = 1;
+	  if (as->corank != 0)
+	    CLASS_DATA (sym)->attr.codimension = 1;
+	}
     }
   else
     {
@@ -8875,9 +8887,24 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 
   if (code->expr2)
     {
-      if (code->expr1->symtree->n.sym->attr.untyped)
-	code->expr1->symtree->n.sym->ts = code->expr2->ts;
-      selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+      gfc_ref *ref2 = NULL;
+      for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
+	 if (ref->type == REF_COMPONENT
+	     && ref->u.c.component->ts.type == BT_CLASS)
+	   ref2 = ref;
+
+      if (ref2)
+	{
+	  if (code->expr1->symtree->n.sym->attr.untyped)
+	    code->expr1->symtree->n.sym->ts = ref->u.c.component->ts;
+	  selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
+	}
+      else
+	{
+	  if (code->expr1->symtree->n.sym->attr.untyped)
+	    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;

gcc/fortran/trans-expr.c

@@ -394,7 +394,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
       e->ref = NULL;
     }
 
-  base_expr = gfc_expr_to_initialize (e);
+  base_expr = gfc_copy_expr (e);
 
   /* Restore the original tail expression.  */
   if (class_ref)
@@ -1131,7 +1131,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 
       /* Return the len component, except in the case of scalarized array
 	references, where the dynamic type cannot change.  */
-      if (!elemental && full_array && copyback)
+      if (!elemental && full_array && copyback
+	  && (UNLIMITED_POLY (e) || VAR_P (tmp)))
 	  gfc_add_modify (&parmse->post, tmp,
 			  fold_convert (TREE_TYPE (tmp), ctree));
     }

gcc/testsuite/ChangeLog

+2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
+	Tobias Burnus  <burnus@gcc.gnu.org>
+
+	PR fortran/87566
+	* gfortran.dg/select_type_44.f90: New test.
+	* gfortran.dg/associate_42.f90: New test.
+
 2018-10-15  Bin Cheng  <bin.cheng@linux.alibaba.com>
 
 	PR tree-optimization/87022

gcc/testsuite/gfortran.dg/associate_42.f90

+! { dg-do run }
+!
+! Tests the fix for a bug that was found in the course of fixing PR87566.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+    call AddArray
+contains
+  subroutine AddArray()
+    type Object_array_pointer
+        class(*), pointer :: p(:) => null()
+    end type Object_array_pointer
+
+    type (Object_array_pointer) :: obj
+    character(3), target :: tgt1(2) = ['one','two']
+    character(5), target :: tgt2(2) = ['three','four ']
+    real, target :: tgt3(3) = [1.0,2.0,3.0]
+
+    obj%p => tgt1
+    associate (point => obj%p)
+      select type (point)         ! Used to ICE here.
+        type is (character(*))
+          if (any (point .ne. tgt1)) stop 1
+      end select
+      point => tgt2
+    end associate
+
+    select type (z => obj%p)
+      type is (character(*))
+        if (any (z .ne. tgt2)) stop 2
+    end select
+
+    obj%p => tgt3
+    associate (point => obj%p)
+      select type (point)
+        type is (real)
+          if (any (point .ne. tgt3)) stop 3
+      end select
+    end associate
+  end subroutine AddArray
+end

gcc/testsuite/gfortran.dg/select_type_44.f90

+! { dg-do run }
+!
+! Test the fix for PR87566
+!
+! Contributed by Antony Lewis  <antony@cosmologist.info>
+!
+  call AddArray
+contains
+  subroutine AddArray()
+    type Object_array_pointer
+        class(*), pointer :: p(:) => null()
+    end type Object_array_pointer
+    class(*), pointer :: Pt => null()
+    type (Object_array_pointer) :: obj
+    character(3), target :: tgt1(2) = ['one','two']
+    character(5), target :: tgt2(2) = ['three','four ']
+
+    allocate (Pt, source = Object_array_pointer ())
+    select type (Pt)
+      type is (object_array_pointer)
+        Pt%p => tgt1
+    end select
+
+    select type (Pt)
+      class is (object_array_pointer)
+        select type (Point=> Pt%P)
+          type is (character(*))
+            if (any (Point .ne. tgt1)) stop 1
+            Point = ['abc','efg']
+        end select
+    end select
+
+    select type (Pt)
+      class is (object_array_pointer)
+        select type (Point=> Pt%P)
+          type is (character(*))
+            if (any (Point .ne. ['abc','efg'])) stop 2
+        end select
+    end select
+
+  end subroutine AddArray
+end