From 0b373205f7bca4702ee464e0d42c99ff96eb1a78 Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 5 Feb 2015 08:02:58 +0000 Subject: [PATCH] 2015-02-05 Paul Thomas 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 PR fortran/640757 * gfortran.dg/type_to_class_2.f90: New test * gfortran.dg/type_to_class_3.f90: New test git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@220435 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 14 ++++++++ gcc/fortran/resolve.c | 3 ++ gcc/fortran/trans-expr.c | 52 +++++++++++++++++++++++++-- gcc/testsuite/ChangeLog | 6 ++++ gcc/testsuite/gfortran.dg/type_to_class_2.f03 | 30 ++++++++++++++++ gcc/testsuite/gfortran.dg/type_to_class_3.f03 | 33 +++++++++++++++++ 6 files changed, 135 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/type_to_class_2.f03 create mode 100644 gcc/testsuite/gfortran.dg/type_to_class_3.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 35504e3dd0b..a60737f2fff 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2015-02-05 Paul Thomas + + 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 * options.c: Include langhooks.h. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bb4240446bf..3b0c12a0e6b 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 6b11fb3c55b..1af3696a922 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 6ae0e63d8b3..1ca16b4873f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2015-02-05 Paul Thomas + + 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 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 00000000000..82f98cc3f4a --- /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 +! + 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 00000000000..7611155a260 --- /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 +! + 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 + + -- 2.11.4.GIT