check.c (gfc_check_move_alloc): Allow nonpolymorphic FROM with polymorphic TO.

2011-12-03  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_move_alloc): Allow nonpolymorphic
        FROM with polymorphic TO.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Handle
        nonpolymorphic FROM with polymorphic TO.

2011-12-03  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/select_type_23.f03: Revert Rev. 181801,
        i.e. remove the dg-error line.
        * gfortran.dg/move_alloc_5.f90: Ditto and change back
        to dg-do run.
        * gfortran.dg/move_alloc_9.f90: New.
        * gfortran.dg/move_alloc_10.f90: New

From-SVN: r181966

3 files changed, 69 insertions, 33 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3fee56d..72a7f74 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_move_alloc): Allow nonpolymorphic
+	FROM with polymorphic TO.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Handle
+	nonpolymorphic FROM with polymorphic TO.
+
 2011-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* module.c (dt_lower_string): Make static.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 832eb64..605c77d 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2688,17 +2688,17 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (allocatable_check (to, 1) == FAILURE)
     return FAILURE;
 
-  if (same_type_check (to, 1, from, 0) == FAILURE)
-    return FAILURE;
-
-  if (to->ts.type != from->ts.type)
+  if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
     {
-      gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be "
-		 "either both polymorphic or both nonpolymorphic",
+      gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
+		 "polymorphic if FROM is polymorphic",
 		 &from->where);
       return FAILURE;
     }
 
+  if (same_type_check (to, 1, from, 0) == FAILURE)
+    return FAILURE;
+
   if (to->rank != from->rank)
     {
       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
@@ -2718,7 +2718,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  /* CLASS arguments: Make sure the vtab is present.  */
+  /* CLASS arguments: Make sure the vtab of from is present.  */
   if (to->ts.type == BT_CLASS)
     gfc_find_derived_vtab (from->ts.u.derived);
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index d055275..855db30 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7184,7 +7184,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
 {
   stmtblock_t block;
   gfc_expr *from_expr, *to_expr;
-  gfc_expr *to_expr2, *from_expr2;
+  gfc_expr *to_expr2, *from_expr2 = NULL;
   gfc_se from_se, to_se;
   gfc_ss *from_ss, *to_ss;
   tree tmp;
@@ -7199,16 +7199,21 @@ conv_intrinsic_move_alloc (gfc_code *code)
 
   if (from_expr->rank == 0)
     {
+      gcc_assert (from_expr->ts.type != BT_CLASS
+		  || to_expr->ts.type == BT_CLASS);
       if (from_expr->ts.type != BT_CLASS)
+	from_expr2 = from_expr;
+      else
 	{
-	  from_expr2 = to_expr;
-	  to_expr2 = to_expr;
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_data_component (from_expr2);
 	}
+
+      if (to_expr->ts.type != BT_CLASS)
+	to_expr2 = to_expr;
       else
 	{
 	  to_expr2 = gfc_copy_expr (to_expr);
-	  from_expr2 = gfc_copy_expr (from_expr);
-	  gfc_add_data_component (from_expr2);
 	  gfc_add_data_component (to_expr2);
 	}
 
@@ -7236,48 +7241,72 @@ conv_intrinsic_move_alloc (gfc_code *code)
       gfc_add_block_to_block (&block, &to_se.post);
 
       /* Set _vptr.  */
-      if (from_expr->ts.type == BT_CLASS)
+      if (to_expr->ts.type == BT_CLASS)
 	{
-	  gfc_free_expr (from_expr2);
-          gfc_free_expr (to_expr2);
-
-	  gfc_init_se (&from_se, NULL);
+	  gfc_free_expr (to_expr2);
 	  gfc_init_se (&to_se, NULL);
-	  from_se.want_pointer = 1;
 	  to_se.want_pointer = 1;
-	  gfc_add_vptr_component (from_expr);
 	  gfc_add_vptr_component (to_expr);
-
-	  gfc_conv_expr (&from_se, from_expr);
 	  gfc_conv_expr (&to_se, to_expr);
+
+	  if (from_expr->ts.type == BT_CLASS)
+	    {
+	      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;
+	    }
+	  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), from_se.expr));
+			      fold_convert (TREE_TYPE (to_se.expr), tmp));
 	}
 
       return gfc_finish_block (&block);
     }
 
   /* Update _vptr component.  */
-  if (from_expr->ts.type == BT_CLASS)
+  if (to_expr->ts.type == BT_CLASS)
     {
-      from_se.want_pointer = 1;
       to_se.want_pointer = 1;
-
-      from_expr2 = gfc_copy_expr (from_expr);
       to_expr2 = gfc_copy_expr (to_expr);
-      gfc_add_vptr_component (from_expr2);
       gfc_add_vptr_component (to_expr2);
-
-      gfc_conv_expr (&from_se, from_expr2);
       gfc_conv_expr (&to_se, to_expr2);
 
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  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;
+	}
+      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), from_se.expr));
+			  fold_convert (TREE_TYPE (to_se.expr), tmp));
       gfc_free_expr (to_expr2);
-      gfc_free_expr (from_expr2);
-
-      gfc_init_se (&from_se, NULL);
       gfc_init_se (&to_se, NULL);
+
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  gfc_free_expr (from_expr2);
+	  gfc_init_se (&from_se, NULL);
+	}
     }
 
   /* Deallocate "to".  */