diff options
author | Tobias Burnus <burnus@net-b.de> | 2012-12-16 15:34:45 +0100 |
---|---|---|
committer | Tobias Burnus <burnus@gcc.gnu.org> | 2012-12-16 15:34:45 +0100 |
commit | f6c28ef193ad29a9eccb01db78efd5aca26ae787 (patch) | |
tree | fa7c37823562aa82e8eda44250880cea4acff47b | |
parent | 2f7d07ff4e1be351696a13f33d4e8b466744071c (diff) | |
download | gcc-f6c28ef193ad29a9eccb01db78efd5aca26ae787.zip gcc-f6c28ef193ad29a9eccb01db78efd5aca26ae787.tar.gz gcc-f6c28ef193ad29a9eccb01db78efd5aca26ae787.tar.bz2 |
trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic type of the FROM variable to the declared type.
2012-12-16 Tobias Burnus <burnus@net-b.de>
* trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic
type of the FROM variable to the declared type.
2012-12-16 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/move_alloc_14.f90: New.
From-SVN: r194536
-rw-r--r-- | gcc/fortran/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 41 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/move_alloc_14.f90 | 22 |
4 files changed, 62 insertions, 10 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8efe003..1deb94d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,10 @@ 2012-12-16 Tobias Burnus <burnus@net-b.de> + * trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic + type of the FROM variable to the declared type. + +2012-12-16 Tobias Burnus <burnus@net-b.de> + PR fortran/55638 * resolve.c (resolve_formal_arglist): Allow VALUE without INTENT for ELEMENTAL procedures. diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 504a9f3..4f74c3f 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 342a1a1..f6503b0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,9 @@ 2012-12-16 Tobias Burnus <burnus@net-b.de> + * gfortran.dg/move_alloc_14.f90: New. + +2012-12-16 Tobias Burnus <burnus@net-b.de> + PR fortran/55638 * gfortran.dg/elemental_args_check_3.f90: Update dg-error. * gfortran.dg/elemental_args_check_7.f90: New. 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 0000000..bc5e4916 --- /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 |