Janus Weil wrote:
>The expr to al->expr change is to pass a BT_CLASS instead of a
>BT_DERIVED. And the NULL to gfc_lval_expr_from_sym change allows to access
>var->_vtab->_final for a BT_CLASS deferred variable.
It seems that both of them will not have any effect right now, but are
useful only as preparation for FINAL, right?
I think that's true. I wanted to claim that it also fixes the following,
but it doesn't:
class(t), allocatable :: a, b, c
allocate (t2 :: a)
call move_alloc (from=a, to=b)
"a" should not only be deallocated but same_type_as(a,c) should be true,
i.e. one has to reset the "a->_vtab" pointer to the declared type.
A follow-up patch which fixes this is attached.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
2012-12-09 Tobias Burnus <bur...@net-b.de>
* trans-intrinsic.c (conv_intrinsic_move_alloc): Set dynamic
type of the FROM variable to the declared type.
2012-12-09 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/move_alloc_14.f90: New.
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/gfortran.dg/move_alloc_14.f90 b/gcc/testsuite/gfortran.dg/move_alloc_14.f90
new file mode 100644
index 0000000..bc5e491
--- /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
