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

	PR fortran/640757
	* resolve.c (resolve_structure_cons): Obtain the rank of class
	components.
	* trans-expr.c (gfc_trans_alloc_subarray_assign): Do the
	assignment to allocatable class array components.
	(alloc_scalar_allocatable_for_subcomponent_assignment): If comp
	is a class component, allocate to the _data field.
	(gfc_trans_subcomponent_assign): If a class component with a
	derived type expression set the _vptr field and for array
	components, call gfc_trans_alloc_subarray_assign. For scalars,
	the assignment is performed here.

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

	PR fortran/640757
	* gfortran.dg/type_to_class_2.f90: New test
	* gfortran.dg/type_to_class_3.f90: New test

From-SVN: r220435

gcc/fortran/ChangeLog

+2015-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/640757
+	* resolve.c (resolve_structure_cons): Obtain the rank of class
+	components.
+	* trans-expr.c (gfc_trans_alloc_subarray_assign): Do the
+	assignment to allocatable class array components.
+	(alloc_scalar_allocatable_for_subcomponent_assignment): If comp
+	is a class component, allocate to the _data field.
+	(gfc_trans_subcomponent_assign): If a class component with a
+	derived type expression set the _vptr field and for array
+	components, call gfc_trans_alloc_subarray_assign. For scalars,
+	the assignment is performed here.
+
 2015-02-04  Jakub Jelinek  <jakub@redhat.com>
 
 	* options.c: Include langhooks.h.

gcc/fortran/resolve.c

@@ -1155,6 +1155,9 @@ resolve_structure_cons (gfc_expr *expr, int init)
 	}
 
       rank = comp->as ? comp->as->rank : 0;
+      if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->as)
+ 	rank = CLASS_DATA (comp)->as->rank;
+
       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
 	  && (comp->attr.allocatable || cons->expr->rank))
 	{

gcc/fortran/trans-expr.c

@@ -6211,6 +6211,20 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
     tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
 			       se.expr, dest,
 			       cm->as->rank);
+  else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
+	   && CLASS_DATA(cm)->attr.allocatable)
+    {
+      if (cm->ts.u.derived->attr.alloc_comp)
+	tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
+				   se.expr, dest,
+				   expr->rank);
+      else
+	{
+	  tmp = TREE_TYPE (dest);
+	  tmp = gfc_duplicate_allocatable (dest, se.expr,
+					   tmp, expr->rank);
+	}
+    }
   else
     tmp = gfc_duplicate_allocatable (dest, se.expr,
 				     TREE_TYPE(cm->backend_decl),
@@ -6335,6 +6349,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 						      gfc_symbol *sym)
 {
   tree tmp;
+  tree ptr;
   tree size;
   tree size_in_bytes;
   tree lhs_cl_size = NULL_TREE;
@@ -6400,8 +6415,12 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
       tmp = build_call_expr_loc (input_location,
 				 builtin_decl_explicit (BUILT_IN_MALLOC),
 				 1, size_in_bytes);
-      tmp = fold_convert (TREE_TYPE (comp), tmp);
-      gfc_add_modify (block, comp, tmp);
+      if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
+	ptr = gfc_class_data_get (comp);
+      else
+	ptr = comp;
+      tmp = fold_convert (TREE_TYPE (ptr), tmp);
+      gfc_add_modify (block, ptr, tmp);
     }
 
   if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
@@ -6420,6 +6439,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
   gfc_se lse;
   stmtblock_t block;
   tree tmp;
+  tree vtab;
 
   gfc_start_block (&block);
 
@@ -6483,6 +6503,20 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
+  else if (cm->ts.type == BT_CLASS
+	   && CLASS_DATA (cm)->attr.dimension
+	   && CLASS_DATA (cm)->attr.allocatable
+	   && expr->ts.type == BT_DERIVED)
+    {
+      vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
+      vtab = gfc_build_addr_expr (NULL_TREE, vtab);
+      tmp = gfc_class_vptr_get (dest);
+      gfc_add_modify (&block, tmp,
+		      fold_convert (TREE_TYPE (tmp), vtab));
+      tmp = gfc_class_data_get (dest);
+      tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
+      gfc_add_expr_to_block (&block, tmp);
+    }
   else if (init && (cm->attr.allocatable
 	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable)))
     {
@@ -6504,7 +6538,19 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
       if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
 	  && expr->symtree->n.sym->attr.dummy)
 	se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
-      tmp = build_fold_indirect_ref_loc (input_location, dest);
+
+      if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
+	{
+	  tmp = gfc_class_data_get (dest);
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	  vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
+	  vtab = gfc_build_addr_expr (NULL_TREE, vtab);
+	  gfc_add_modify (&block, gfc_class_vptr_get (dest),
+		 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
+	}
+      else
+	tmp = build_fold_indirect_ref_loc (input_location, dest);
+
       /* For deferred strings insert a memcpy.  */
       if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
 	{

gcc/testsuite/ChangeLog

+2015-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/640757
+	* gfortran.dg/type_to_class_2.f90: New test
+	* gfortran.dg/type_to_class_3.f90: New test
+
 2015-02-04  Jan Hubicka  <hubicka@ucw.cz>
 
 	PR ipa/64686

gcc/testsuite/gfortran.dg/type_to_class_2.f03

+! { dg-do run }
+!
+! Test the fix for PR64757.
+!
+! Contributed by Michael Lee Rilee  <mike@rilee.net>
+!
+  type :: Test
+    integer :: i
+  end type
+
+  type :: TestReference
+     class(Test), allocatable :: test
+  end type
+
+  type(TestReference) :: testList
+  type(test) :: x
+
+  testList = TestReference(Test(99))  ! ICE in fold_convert_loc was here
+
+  x = testList%test
+
+  select type (y => testList%test)    ! Check vptr set
+    type is (Test)
+      if (x%i .ne. y%i) call abort
+    class default
+      call abort
+  end select
+end
+
+

gcc/testsuite/gfortran.dg/type_to_class_3.f03

+! { dg-do run }
+!
+! Test the fix for the array version of PR64757.
+!
+! Based on by Michael Lee Rilee  <mike@rilee.net>
+!
+  type :: Test
+    integer :: i
+  end type
+
+  type :: TestReference
+     class(Test), allocatable :: test(:)
+  end type
+
+  type(TestReference) :: testList
+  type(test), allocatable :: x(:)
+
+  testList = TestReference([Test(99), Test(199)])  ! Gave: The rank of the element in the
+                                                   ! structure constructor at (1) does not
+                                                   ! match that of the component (1/0)
+! allocate (testList%test(2), source = [Test(99), Test(199)]) ! Works, of course
+
+  x = testList%test
+
+  select type (y => testList%test)    ! Check vptr set
+    type is (Test)
+      if (any(x%i .ne. y%i)) call abort
+    class default
+      call abort
+  end select
+end
+
+