diff options
author | burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-12-28 11:22:14 +0000 |
---|---|---|
committer | burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-12-28 11:22:14 +0000 |
commit | 7434f296c21b16c852839ec11874ac8fe5fb518a (patch) | |
tree | 12254814161ab792663751f405fa5cca5c701f75 | |
parent | cf947748084d9ad7a140cc5f6a742e9e5b1c6f92 (diff) | |
download | gcc-7434f296c21b16c852839ec11874ac8fe5fb518a.tar.gz |
2012-12-28 Tobias Burnus <burnus@net-b.de>
PR fortran/55763
* check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
2012-12-28 Tobias Burnus <burnus@net-b.de>
PR fortran/55763
* gfortran.dg/unlimited_polymorphic_5.f90
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194743 138bc75d-0d04-0410-961f-82ee72b054a4
-rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/fortran/check.c | 15 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 54 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90 | 41 |
5 files changed, 100 insertions, 21 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a8d6a21c8ab..d04897eabfa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2012-12-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/55763 + * check.c (gfc_check_move_alloc): Handle unlimited polymorphic. + * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto. + 2012-12-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR fortran/48976 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 793ad75d701..0923f121215 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 b9d13ccaecd..5a89be1a98d 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/ChangeLog b/gcc/testsuite/ChangeLog index ffe56e980ff..38935dc13fa 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-12-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/55763 + * gfortran.dg/unlimited_polymorphic_5.f90 + 2012-12-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR fortran/48960 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 00000000000..12a3c4a5624 --- /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 |