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

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