From patchwork Fri Dec 21 18:42:14 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Fortran] PR55763 - Fix MOVE_ALLOC with CLASS(*) Date: Fri, 21 Dec 2012 08:42:14 -0000 From: Tobias Burnus X-Patchwork-Id: 207870 Message-Id: <50D4AD86.4090301@net-b.de> To: gcc patches , gfortran Fix one of the remaining issues of PR 55763: MOVE_ALLOC with CLASS(*) either for both arguments or only for TO=. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2012-12-21 Tobias Burnus PR fortran/55763 * check.c (gfc_check_move_alloc): Handle unlimited polymorphic. * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto. 2012-12-21 Tobias Burnus PR fortran/55763 * gfortran.dg/unlimited_polymorphic_5.f90 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 793ad75..0923f12 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2791,18 +2791,15 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) return FAILURE; } - if (to->ts.kind != from->ts.kind) + /* CLASS arguments: Make sure the vtab of from is present. */ + if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) { - gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L" - " must be of the same kind %d/%d", &to->where, from->ts.kind, - to->ts.kind); - return FAILURE; + if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED) + gfc_find_derived_vtab (from->ts.u.derived); + else + gfc_find_intrinsic_vtab (&from->ts); } - /* CLASS arguments: Make sure the vtab of from is present. */ - if (to->ts.type == BT_CLASS) - gfc_find_derived_vtab (from->ts.u.derived); - return SUCCESS; } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b9d13cc..5a89be1 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7373,8 +7373,13 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->ts.type == BT_CLASS) { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); + if (UNLIMITED_POLY (from_expr)) + vtab = NULL; + else + { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + } gfc_free_expr (from_expr2); gfc_init_se (&from_se, NULL); @@ -7386,13 +7391,23 @@ conv_intrinsic_move_alloc (gfc_code *code) from_se.expr)); /* Reset _vptr component to declared type. */ - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); + if (UNLIMITED_POLY (from_expr)) + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), + null_pointer_node)); + else + { + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); + } } else { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + if (from_expr->ts.type != BT_DERIVED) + vtab = gfc_find_intrinsic_vtab (&from_expr->ts); + else + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); gfc_add_modify_loc (input_location, &block, to_se.expr, @@ -7415,8 +7430,13 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->ts.type == BT_CLASS) { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); + if (UNLIMITED_POLY (from_expr)) + vtab = NULL; + else + { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + } from_se.want_pointer = 1; from_expr2 = gfc_copy_expr (from_expr); @@ -7427,13 +7447,23 @@ conv_intrinsic_move_alloc (gfc_code *code) from_se.expr)); /* Reset _vptr component to declared type. */ - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); + if (UNLIMITED_POLY (from_expr)) + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), + null_pointer_node)); + else + { + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); + } } else { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + if (from_expr->ts.type != BT_DERIVED) + vtab = gfc_find_intrinsic_vtab (&from_expr->ts); + else + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); gfc_add_modify_loc (input_location, &block, to_se.expr, diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90 new file mode 100644 index 0000000..12a3c4a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/55763 +! +! Based on Reinhold Bader's test case +! + +program mvall_03 + implicit none + integer, parameter :: n1 = 100, n2 = 200 + class(*), allocatable :: i1(:), i3(:) + integer, allocatable :: i2(:) + + allocate(real :: i1(n1)) + allocate(i2(n2)) + i2 = 2 + call move_alloc(i2, i1) + if (size(i1) /= n2 .or. allocated(i2)) then + call abort +! write(*,*) 'FAIL' + else +! write(*,*) 'OK' + end if + + select type (i1) + type is (integer) + if (any (i1 /= 2)) call abort + class default + call abort() + end select + call move_alloc (i1, i3) + if (size(i3) /= n2 .or. allocated(i1)) then + call abort() + end if + select type (i3) + type is (integer) + if (any (i3 /= 2)) call abort + class default + call abort() + end select +end program