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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 35504e3dd0ba8706b0a402ed3be565015d5bc5cd..a60737f2fff9aa9d8ff2cf81003c28d9a98bf493 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bb4240446bf83f18a09abd4114379b10cb5ddbec..3b0c12a0e6be31dd6c97dd4663995b32d6476e47 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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))
        {

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6b11fb3c55b9773a6ec3f123f18a011f0caf207a..1af3696a922f09725c6a55fd1b9bc43f3f0ffa2f 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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)
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6ae0e63d8b3b5d3eeeea06c7e9841375d57a2f7d..1ca16b4873fdd177f2cac235b1739503f9723db3 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/type_to_class_2.f03 b/gcc/testsuite/gfortran.dg/type_to_class_2.f03
new file mode 100644 (file)
index 0000000..82f98cc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_to_class_2.f03
@@ -0,0 +1,30 @@
+! { 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
+
+

diff --git a/gcc/testsuite/gfortran.dg/type_to_class_3.f03 b/gcc/testsuite/gfortran.dg/type_to_class_3.f03
new file mode 100644 (file)
index 0000000..7611155
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_to_class_3.f03
@@ -0,0 +1,33 @@
+! { 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
+
+