From: Tobias Burnus Date: Sun, 16 Dec 2012 14:34:45 +0000 (+0100) Subject: trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic type of the FROM variable... X-Git-Tag: releases/gcc-4.8.0~1355 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=f6c28ef193ad29a9eccb01db78efd5aca26ae787;p=thirdparty%2Fgcc.git trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic type of the FROM variable to the declared type. 2012-12-16 Tobias Burnus * trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic type of the FROM variable to the declared type. 2012-12-16 Tobias Burnus * gfortran.dg/move_alloc_14.f90: New. From-SVN: r194536 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8efe003240fd..1deb94d39378 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2012-12-16 Tobias Burnus + + * trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic + type of the FROM variable to the declared type. + 2012-12-16 Tobias Burnus PR fortran/55638 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 504a9f3b8fcb..4f74c3ff29ab 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7338,6 +7338,8 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Set _vptr. */ if (to_expr->ts.type == BT_CLASS) { + gfc_symbol *vtab; + gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); to_se.want_pointer = 1; @@ -7346,23 +7348,31 @@ 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); + gfc_free_expr (from_expr2); gfc_init_se (&from_se, NULL); from_se.want_pointer = 1; gfc_add_vptr_component (from_expr); gfc_conv_expr (&from_se, from_expr); - tmp = from_se.expr; + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + 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)); } else { - gfc_symbol *vtab; 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, + fold_convert (TREE_TYPE (to_se.expr), tmp)); } - - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); } return gfc_finish_block (&block); @@ -7371,6 +7381,8 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Update _vptr component. */ if (to_expr->ts.type == BT_CLASS) { + gfc_symbol *vtab; + to_se.want_pointer = 1; to_expr2 = gfc_copy_expr (to_expr); gfc_add_vptr_component (to_expr2); @@ -7378,22 +7390,31 @@ 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); + from_se.want_pointer = 1; from_expr2 = gfc_copy_expr (from_expr); gfc_add_vptr_component (from_expr2); gfc_conv_expr (&from_se, from_expr2); - tmp = from_se.expr; + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + 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)); } else { - gfc_symbol *vtab; 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, + fold_convert (TREE_TYPE (to_se.expr), tmp)); } - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); @@ -7449,7 +7470,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Move the pointer and update the array descriptor data. */ gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); - /* Set "to" to NULL. */ + /* Set "from" to NULL. */ tmp = gfc_conv_descriptor_data_get (from_se.expr); gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 342a1a149574..f6503b094dac 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2012-12-16 Tobias Burnus + + * gfortran.dg/move_alloc_14.f90: New. + 2012-12-16 Tobias Burnus PR fortran/55638 diff --git a/gcc/testsuite/gfortran.dg/move_alloc_14.f90 b/gcc/testsuite/gfortran.dg/move_alloc_14.f90 new file mode 100644 index 000000000000..bc5e49165129 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_14.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Ensure that move_alloc for CLASS resets the FROM variable's dynamic type +! to the declared one +! +implicit none +type t +end type t +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: a, b, c +class(t), allocatable :: a2(:), b2(:), c2(:) +allocate (t2 :: a) +allocate (t2 :: a2(5)) +call move_alloc (from=a, to=b) +call move_alloc (from=a2, to=b2) +!print *, same_type_as (a,c), same_type_as (a,b) +!print *, same_type_as (a2,c2), same_type_as (a2,b2) +if (.not. same_type_as (a,c) .or. same_type_as (a,b)) call abort () +if (.not. same_type_as (a2,c2) .or. same_type_as (a2,b2)) call abort () +end