aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaul Thomas <pault@gcc.gnu.org>2015-02-05 08:02:58 +0000
committerPaul Thomas <pault@gcc.gnu.org>2015-02-05 08:02:58 +0000
commit3cd52c11b284c1123b1782dc5629d22a42844c37 (patch)
tree460ab48d46937485d07108170047c95303e18d38
parenta0cbab4acd8f7af1ece6d94e61d5c754246c5efa (diff)
downloadgcc-3cd52c11b284c1123b1782dc5629d22a42844c37.zip
gcc-3cd52c11b284c1123b1782dc5629d22a42844c37.tar.gz
gcc-3cd52c11b284c1123b1782dc5629d22a42844c37.tar.bz2
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
-rw-r--r--gcc/fortran/ChangeLog14
-rw-r--r--gcc/fortran/resolve.c3
-rw-r--r--gcc/fortran/trans-expr.c52
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/type_to_class_2.f0330
-rw-r--r--gcc/testsuite/gfortran.dg/type_to_class_3.f0333
6 files changed, 135 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 35504e3..a60737f 100644
--- 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 bb42404..3b0c12a 100644
--- 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 6b11fb3..1af3696 100644
--- 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 6ae0e63..1ca16b4 100644
--- 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
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
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
+
+