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 <bur...@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-21 Tobias Burnus <bur...@net-b.de>
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
