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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194536 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8efe003..1deb94d 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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