Add gfc_class_set_vptr.

First step to adding a general assign all class type's data members
routine.  Having a general routine prevents forgetting to tackle the
edge cases, e.g. setting _len.

gcc/fortran/ChangeLog:

	* trans-expr.cc (gfc_class_set_vptr): Add setting of _vptr
	member.
	* trans-intrinsic.cc (conv_intrinsic_move_alloc): First use
	of gfc_class_set_vptr and refactor very similar code.
	* trans.h (gfc_class_set_vptr): Declare the new function.

gcc/testsuite/ChangeLog:

	* gfortran.dg/unlimited_polymorphic_11.f90: Remove unnecessary
	casts in gd-final expression.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 454b87581f57caca02820348144b0beefec55a4b..477c2720187e9dfa205bdc157c6066659a00b135 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -599,6 +599,54 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
 }
 
 
+/* Set the vptr of a class in to from the type given in from.  If from is NULL,
+   then reset the vptr to the default or to.  */
+
+void
+gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
+{
+  tree tmp, vptr_ref;
+
+  vptr_ref = gfc_get_vptr_from_expr (to);
+  if (POINTER_TYPE_P (TREE_TYPE (from))
+      && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
+    {
+      gfc_add_modify (block, vptr_ref,
+                     fold_convert (TREE_TYPE (vptr_ref),
+                                   gfc_get_vptr_from_expr (from)));
+    }
+  else if (VAR_P (from)
+          && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
+    {
+      gfc_add_modify (block, vptr_ref,
+                     gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
+    }
+  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
+          && GFC_CLASS_TYPE_P (
+            TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
+    {
+      gfc_add_modify (block, vptr_ref,
+                     fold_convert (TREE_TYPE (vptr_ref),
+                                   gfc_get_vptr_from_expr (TREE_OPERAND (
+                                     TREE_OPERAND (from, 0), 0))));
+    }
+  else
+    {
+      tree vtab;
+      gfc_symbol *type;
+      tmp = TREE_TYPE (from);
+      if (POINTER_TYPE_P (tmp))
+       tmp = TREE_TYPE (tmp);
+      gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
+                      &type);
+      vtab = gfc_find_derived_vtab (type)->backend_decl;
+      gcc_assert (vtab);
+      gfc_add_modify (block, vptr_ref,
+                     gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab));
+    }
+}
+
+
 /* Reset the len for unlimited polymorphic objects.  */
 
 void

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ac7fcd250d382c3870ba654130de65a958f09d73..5ea10e84060951a73f0a96e08399576f9d27a473 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -12667,10 +12667,9 @@ conv_intrinsic_move_alloc (gfc_code *code)
 {
   stmtblock_t block;
   gfc_expr *from_expr, *to_expr;
-  gfc_expr *to_expr2, *from_expr2 = NULL;
   gfc_se from_se, to_se;
-  tree tmp;
-  bool coarray;
+  tree tmp, to_tree, from_tree;
+  bool coarray, from_is_class, from_is_scalar;
 
   gfc_start_block (&block);
 
@@ -12680,178 +12679,94 @@ conv_intrinsic_move_alloc (gfc_code *code)
   gfc_init_se (&from_se, NULL);
   gfc_init_se (&to_se, NULL);
 
-  gcc_assert (from_expr->ts.type != BT_CLASS
-             || to_expr->ts.type == BT_CLASS);
+  gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
   coarray = gfc_get_corank (from_expr) != 0;
 
-  if (from_expr->rank == 0 && !coarray)
+  from_is_class = from_expr->ts.type == BT_CLASS;
+  from_is_scalar = from_expr->rank == 0 && !coarray;
+  if (to_expr->ts.type == BT_CLASS || from_is_scalar)
     {
-      if (from_expr->ts.type != BT_CLASS)
-       from_expr2 = from_expr;
+      from_se.want_pointer = 1;
+      if (from_is_scalar)
+       gfc_conv_expr (&from_se, from_expr);
       else
-       {
-         from_expr2 = gfc_copy_expr (from_expr);
-         gfc_add_data_component (from_expr2);
-       }
-
-      if (to_expr->ts.type != BT_CLASS)
-       to_expr2 = to_expr;
+       gfc_conv_expr_descriptor (&from_se, from_expr);
+      if (from_is_class)
+       from_tree = gfc_class_data_get (from_se.expr);
       else
        {
-         to_expr2 = gfc_copy_expr (to_expr);
-         gfc_add_data_component (to_expr2);
+         gfc_symbol *vtab;
+         from_tree = from_se.expr;
+
+         vtab = gfc_find_vtab (&from_expr->ts);
+         gcc_assert (vtab);
+         from_se.expr = gfc_get_symbol_decl (vtab);
        }
+      gfc_add_block_to_block (&block, &from_se.pre);
 
-      from_se.want_pointer = 1;
       to_se.want_pointer = 1;
-      gfc_conv_expr (&from_se, from_expr2);
-      gfc_conv_expr (&to_se, to_expr2);
-      gfc_add_block_to_block (&block, &from_se.pre);
+      if (to_expr->rank == 0)
+       gfc_conv_expr (&to_se, to_expr);
+      else
+       gfc_conv_expr_descriptor (&to_se, to_expr);
+      if (to_expr->ts.type == BT_CLASS)
+       to_tree = gfc_class_data_get (to_se.expr);
+      else
+       to_tree = to_se.expr;
       gfc_add_block_to_block (&block, &to_se.pre);
 
       /* Deallocate "to".  */
-      tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
-                                              true, to_expr, to_expr->ts);
-      gfc_add_expr_to_block (&block, tmp);
+      if (to_expr->rank == 0)
+       {
+         tmp
+           = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE,
+                                                true, to_expr, to_expr->ts);
+         gfc_add_expr_to_block (&block, tmp);
+       }
 
-      /* Assign (_data) pointers.  */
-      gfc_add_modify_loc (input_location, &block, to_se.expr,
-                         fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+      if (from_is_scalar)
+       {
+         /* Assign (_data) pointers.  */
+         gfc_add_modify_loc (input_location, &block, to_tree,
+                             fold_convert (TREE_TYPE (to_tree), from_tree));
 
-      /* Set "from" to NULL.  */
-      gfc_add_modify_loc (input_location, &block, from_se.expr,
-                         fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+         /* Set "from" to NULL.  */
+         gfc_add_modify_loc (input_location, &block, from_tree,
+                             fold_convert (TREE_TYPE (from_tree),
+                                           null_pointer_node));
 
-      gfc_add_block_to_block (&block, &from_se.post);
+         gfc_add_block_to_block (&block, &from_se.post);
+       }
       gfc_add_block_to_block (&block, &to_se.post);
 
       /* 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;
-         gfc_add_vptr_component (to_expr);
-         gfc_conv_expr (&to_se, to_expr);
-
-         if (from_expr->ts.type == BT_CLASS)
-           {
-             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);
-             from_se.want_pointer = 1;
-             gfc_add_vptr_component (from_expr);
-             gfc_conv_expr (&from_se, from_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.  */
-             if (vtab == NULL)
-               /* Unlimited polymorphic.  */
-               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_vtab (&from_expr->ts);
-             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));
-           }
-       }
-
-      if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
-       {
-         gfc_add_modify_loc (input_location, &block, to_se.string_length,
-                             fold_convert (TREE_TYPE (to_se.string_length),
-                                           from_se.string_length));
-         if (from_expr->ts.deferred)
-           gfc_add_modify_loc (input_location, &block, from_se.string_length,
-                       build_int_cst (TREE_TYPE (from_se.string_length), 0));
+         gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
+         if (from_is_class)
+           gfc_reset_vptr (&block, from_expr);
        }
 
-      return gfc_finish_block (&block);
-    }
-
-  /* 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);
-      gfc_conv_expr (&to_se, to_expr2);
-
-      if (from_expr->ts.type == BT_CLASS)
+      if (from_is_scalar)
        {
-         if (UNLIMITED_POLY (from_expr))
-           vtab = NULL;
-         else
+         if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
            {
-             vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
-             gcc_assert (vtab);
+             gfc_add_modify_loc (input_location, &block, to_se.string_length,
+                                 fold_convert (TREE_TYPE (to_se.string_length),
+                                               from_se.string_length));
+             if (from_expr->ts.deferred)
+               gfc_add_modify_loc (
+                 input_location, &block, from_se.string_length,
+                 build_int_cst (TREE_TYPE (from_se.string_length), 0));
            }
 
-         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);
-         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.  */
-         if (vtab == NULL)
-           /* Unlimited polymorphic.  */
-           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_vtab (&from_expr->ts);
-         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));
+         return gfc_finish_block (&block);
        }
 
-      gfc_free_expr (to_expr2);
       gfc_init_se (&to_se, NULL);
-
-      if (from_expr->ts.type == BT_CLASS)
-       {
-         gfc_free_expr (from_expr2);
-         gfc_init_se (&from_se, NULL);
-       }
+      gfc_init_se (&from_se, NULL);
     }
 
-
   /* Deallocate "to".  */
   if (from_expr->rank == 0)
     {

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index f019c89edf22407d4ffc15829865ecfe1c24a054..ec04aede0fd218f6d0750a389a9d3e6c349f0083 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -451,9 +451,9 @@ tree gfc_vptr_def_init_get (tree);
 tree gfc_vptr_copy_get (tree);
 tree gfc_vptr_final_get (tree);
 tree gfc_vptr_deallocate_get (tree);
-void
-gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE,
-               gfc_symbol * = nullptr);
+void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE,
+                    gfc_symbol * = nullptr);
+void gfc_class_set_vptr (stmtblock_t *, tree, tree);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_class_from_gfc_expr (gfc_expr *);
 tree gfc_get_class_from_expr (tree);

diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90
index bbd3d067f3fa28cf6223bee834bc03a25c22c131..653992f40eb03419f95b0923a054ad45f6094fa4 100644 (file)
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90
@@ -10,4 +10,4 @@
   call move_alloc(a,c)
 end
 
-! { dg-final { scan-tree-dump "\\(struct __vtype__STAR \\*\\) c._vptr = \\(struct __vtype__STAR \\*\\) a._vptr;" "original" } }
+! { dg-final { scan-tree-dump "c._vptr = a._vptr;" "original" } }