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

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.

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);
 

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);
 
-      gfc_add_modify_loc (input_location, &block, to_se.expr,
-			  fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
-      gfc_free_expr (to_expr2);
-      gfc_free_expr (from_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_init_se (&from_se, NULL);
+      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);
+
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  gfc_free_expr (from_expr2);
+	  gfc_init_se (&from_se, NULL);
+	}
     }
 
   /* Deallocate "to".  */

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+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
+
 2011-12-02  Nathan Sidwell  <nathan@acm.org>
 
 	* lib/gcov.exp (verify-lines): Allow = as a count char.

gcc/testsuite/gfortran.dg/move_alloc_10.f90

@@ -0,0 +1,79 @@
+! { dg-do run }
+!
+! Test move_alloc for polymorphic scalars
+!
+! The following checks that a move_alloc from
+! a TYPE to a CLASS works
+!
+module myalloc
+  implicit none
+
+  type :: base_type
+     integer :: i  =2
+  end type base_type
+
+  type, extends(base_type) :: extended_type
+     integer :: j = 77
+  end type extended_type
+contains
+  subroutine myallocate (a)
+    class(base_type), allocatable, intent(inout) :: a
+    type(extended_type), allocatable :: tmp
+
+   allocate (tmp)
+
+   if (tmp%i /= 2 .or. tmp%j /= 77) call abort()
+   tmp%i = 5
+   tmp%j = 88
+
+   select type(a)
+     type is(base_type)
+       if (a%i /= -44) call abort()
+       a%i = -99
+     class default
+       call abort ()
+   end select
+
+   call move_alloc (from=tmp, to=a)
+
+   select type(a)
+     type is(extended_type)
+       if (a%i /= 5) call abort()
+       if (a%j /= 88) call abort()
+       a%i = 123
+       a%j = 9498
+     class default
+       call abort ()
+   end select
+
+   if (allocated (tmp)) call abort()
+  end subroutine myallocate
+end module myalloc
+
+program main
+  use myalloc
+  implicit none
+  class(base_type), allocatable :: a
+
+  allocate (a)
+
+  select type(a)
+    type is(base_type)
+      if (a%i /= 2) call abort()
+      a%i = -44
+    class default
+      call abort ()
+  end select
+
+  call myallocate (a)
+
+  select type(a)
+    type is(extended_type)
+      if (a%i /= 123) call abort()
+      if (a%j /= 9498) call abort()
+    class default
+      call abort ()
+  end select
+end program main
+
+! { dg-final { cleanup-modules "myalloc" } }

gcc/testsuite/gfortran.dg/move_alloc_5.f90

@@ -1,4 +1,4 @@
-! { dg-do compile }
+! { dg-do run }
 !
 ! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE
 !
@@ -16,7 +16,7 @@ program testmv1
   type(bar2), allocatable :: sm2
 
   allocate (sm2)
-  call move_alloc (sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
+  call move_alloc (sm2,sm)
 
   if (allocated(sm2)) call abort()
   if (.not. allocated(sm)) call abort()

gcc/testsuite/gfortran.dg/move_alloc_9.f90

@@ -0,0 +1,57 @@
+! { dg-do compile }
+!
+! Test diagnostic for MOVE_ALLOC:
+! FROM=type, TO=class is OK
+! FROM=class, TO=type is INVALID
+!
+module m2
+  type, abstract :: t2
+  contains
+    procedure(intf), deferred, nopass :: f
+  end type t2
+
+  interface
+    function intf()
+      import
+      class(t2), allocatable :: intf
+    end function intf
+  end interface
+end module m2
+
+module m3
+  use m2
+  type, extends(t2) :: t3
+  contains
+    procedure,nopass :: f => my_f
+  end type t3
+contains
+   function my_f()
+     class(t2), allocatable :: my_f
+   end function my_f
+end module m3
+
+subroutine my_test
+use m3
+type(t3), allocatable :: x
+class(t2), allocatable :: y
+call move_alloc (x, y)
+end subroutine my_test
+
+program testmv1
+  type bar
+  end type
+
+  type, extends(bar) ::  bar2
+  end type
+
+  class(bar), allocatable :: sm
+  type(bar2), allocatable :: sm2
+
+  allocate (sm2)
+  call move_alloc (sm,sm2) ! { dg-error "must be polymorphic if FROM is polymorphic" }
+
+  if (allocated(sm2)) call abort()
+  if (.not. allocated(sm)) call abort()
+end program 
+
+! { dg-final { cleanup-modules "m2 m3" } }

gcc/testsuite/gfortran.dg/select_type_23.f03

@@ -3,10 +3,6 @@
 ! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE
 !
 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
-!
-! Note that per Fortran 2008, 8.1.9.2, "within the block following
-! a TYPE IS type guard statement, the associating entity (16.5.5) is not polymorphic"
-!
 
 program testmv2
 
@@ -20,7 +16,7 @@ program testmv2
 
   select type(sm2) 
   type is (bar)
-    call move_alloc(sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
+    call move_alloc(sm2,sm)
   end select
 
 end program testmv2