re PR fortran/55763 (Issues with some simpler CLASS(*) programs)

2012-12-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.

2012-12-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/unlimited_polymorphic_5.f90

From-SVN: r194743

gcc/fortran/ChangeLog

+2012-12-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
+
 2012-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/48976

gcc/fortran/check.c

@@ -2791,18 +2791,15 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  if (to->ts.kind != from->ts.kind)
+  /* CLASS arguments: Make sure the vtab of from is present.  */
+  if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
     {
-      gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
-		 " must be of the same kind %d/%d", &to->where, from->ts.kind,
-		 to->ts.kind);
-      return FAILURE;
+      if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
+	gfc_find_derived_vtab (from->ts.u.derived);
+      else
+	gfc_find_intrinsic_vtab (&from->ts);
     }
 
-  /* CLASS arguments: Make sure the vtab of from is present.  */
-  if (to->ts.type == BT_CLASS)
-    gfc_find_derived_vtab (from->ts.u.derived);
-
   return SUCCESS;
 }
 

gcc/fortran/trans-intrinsic.c

@@ -7373,8 +7373,13 @@ 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);
+	      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);
@@ -7386,13 +7391,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
 				  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));
+	      if (UNLIMITED_POLY (from_expr))
+		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_derived_vtab (from_expr->ts.u.derived);
+	      if (from_expr->ts.type != BT_DERIVED)
+		vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
+	      else
+		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,
@@ -7415,8 +7430,13 @@ 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);
+	  if (UNLIMITED_POLY (from_expr))
+	    vtab = NULL;
+	  else
+	    {
+	      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);
@@ -7427,13 +7447,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
 			      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));
+	  if (UNLIMITED_POLY (from_expr))
+	    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_derived_vtab (from_expr->ts.u.derived);
+	  if (from_expr->ts.type != BT_DERIVED)
+	    vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
+	  else
+	    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,

gcc/testsuite/ChangeLog

+2012-12-28  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* gfortran.dg/unlimited_polymorphic_5.f90
+
 2012-12-27  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/48960

gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90

+! { dg-do run }
+!
+! PR fortran/55763
+!
+! Based on Reinhold Bader's test case
+!
+
+program mvall_03
+  implicit none
+  integer, parameter :: n1 = 100, n2 = 200
+  class(*), allocatable :: i1(:), i3(:)
+  integer, allocatable :: i2(:)
+
+  allocate(real :: i1(n1))
+  allocate(i2(n2))
+  i2 = 2
+  call move_alloc(i2, i1)
+  if (size(i1) /= n2 .or. allocated(i2)) then
+    call abort
+!   write(*,*) 'FAIL'
+  else
+!    write(*,*) 'OK'
+  end if
+
+  select type (i1)
+    type is (integer)
+      if (any (i1 /= 2)) call abort
+    class default
+      call abort()
+  end select
+  call move_alloc (i1, i3)
+  if (size(i3) /= n2 .or. allocated(i1)) then
+    call abort()
+  end if
+  select type (i3)
+    type is (integer)
+      if (any (i3 /= 2)) call abort
+    class default
+      call abort()
+  end select
+end program