2012-11-06 Janus Weil <janus@gcc.gnu.org>

	PR fortran/54917
	* target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr):
	Handle BT_CLASS.
	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Add support for
	polymorphic arguments.

2012-11-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54917
	* gfortran.dg/transfer_class_1.f90: New.
	* gfortran.dg/transfer_class_2.f90: New.


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

6 files changed, 139 insertions, 17 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 084f1f8c53b..f33dffb0f64 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2012-11-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54917
+	* target-memory.c (gfc_target_expr_size,gfc_target_interpret_expr):
+	Handle BT_CLASS.
+	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Add support for
+	polymorphic arguments.
+
 2012-11-04  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/55199
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index aec7fa207bd..437a3df8304 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -121,6 +121,7 @@ gfc_target_expr_size (gfc_expr *e)
     case BT_HOLLERITH:
       return e->representation.length;
     case BT_DERIVED:
+    case BT_CLASS:
       {
 	/* Determine type size without clobbering the typespec for ISO C
 	   binding types.  */
@@ -572,6 +573,9 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
         gfc_interpret_character (buffer, buffer_size, result);
       break;
 
+    case BT_CLASS:
+      result->ts = CLASS_DATA (result)->ts;
+      /* Fall through.  */
     case BT_DERIVED:
       result->representation.length = 
         gfc_interpret_derived (buffer, buffer_size, result);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4b268b34ba7..b101cb46728 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5348,6 +5348,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   stmtblock_t block;
   int n;
   bool scalar_mold;
+  gfc_expr *source_expr, *mold_expr;
 
   info = NULL;
   if (se->loop)
@@ -5357,6 +5358,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	source_bytes = length of the source in bytes
 	source = pointer to the source data.  */
   arg = expr->value.function.actual;
+  source_expr = arg->expr;
 
   /* Ensure double transfer through LOGICAL preserves all
      the needed bits.  */
@@ -5376,18 +5378,28 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   if (arg->expr->rank == 0)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
-      source = argse.expr;
-
-      source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
-							argse.expr));
+      if (arg->expr->ts.type == BT_CLASS)
+	source = gfc_class_data_get (argse.expr);
+      else
+	source = argse.expr;
 
       /* Obtain the source word length.  */
-      if (arg->expr->ts.type == BT_CHARACTER)
-	tmp = size_of_string_in_bytes (arg->expr->ts.kind,
-				       argse.string_length);
-      else
-	tmp = fold_convert (gfc_array_index_type,
-			    size_in_bytes (source_type)); 
+      switch (arg->expr->ts.type)
+	{
+	case BT_CHARACTER:
+	  tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+					 argse.string_length);
+	  break;
+	case BT_CLASS:
+	  tmp = gfc_vtable_size_get (argse.expr);
+	  break;
+	default:
+	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+								source));
+	  tmp = fold_convert (gfc_array_index_type,
+			      size_in_bytes (source_type));
+	  break;
+	}
     }
   else
     {
@@ -5464,6 +5476,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	mold_type = the TREE type of MOLD
 	dest_word_len = destination word length in bytes.  */
   arg = arg->next;
+  mold_expr = arg->expr;
 
   gfc_init_se (&argse, NULL);
 
@@ -5473,7 +5486,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
-						      argse.expr));
+							  argse.expr));
     }
   else
     {
@@ -5494,15 +5507,20 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	mold_type = gfc_get_int_type (arg->expr->ts.kind);
     }
 
-  if (arg->expr->ts.type == BT_CHARACTER)
+  /* Obtain the destination word length.  */
+  switch (arg->expr->ts.type)
     {
+    case BT_CHARACTER:
       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+      break;
+    case BT_CLASS:
+      tmp = gfc_vtable_size_get (argse.expr);
+      break;
+    default:
+      tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
+      break;
     }
-  else
-    tmp = fold_convert (gfc_array_index_type,
-			size_in_bytes (mold_type)); 
- 
   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
   gfc_add_modify (&se->pre, dest_word_len, tmp);
 
@@ -5650,8 +5668,21 @@ scalar_transfer:
 
       ptr = convert (build_pointer_type (mold_type), source);
 
+      /* For CLASS results, allocate the needed memory first.  */
+      if (mold_expr->ts.type == BT_CLASS)
+	{
+	  tree cdata;
+	  cdata = gfc_class_data_get (tmpdecl);
+	  tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
+	  gfc_add_modify (&se->pre, cdata, tmp);
+	}
+
       /* Use memcpy to do the transfer.  */
-      tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
+      if (mold_expr->ts.type == BT_CLASS)
+	tmp = gfc_class_data_get (tmpdecl);
+      else
+	tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
+
       tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
 			     fold_convert (pvoid_type_node, tmp),
@@ -5659,6 +5690,18 @@ scalar_transfer:
 			     extent);
       gfc_add_expr_to_block (&se->pre, tmp);
 
+      /* For CLASS results, set the _vptr.  */
+      if (mold_expr->ts.type == BT_CLASS)
+	{
+	  tree vptr;
+	  gfc_symbol *vtab;
+	  vptr = gfc_class_vptr_get (tmpdecl);
+	  vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
+	  gcc_assert (vtab);
+	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	  gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
+	}
+
       se->expr = tmpdecl;
     }
 }
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e44a637b1ee..c4d388dfba2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-11-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54917
+	* gfortran.dg/transfer_class_1.f90: New.
+	* gfortran.dg/transfer_class_2.f90: New.
+
 2012-11-05  Sriraman Tallam  <tmsriram@google.com>
 
 	* testsuite/g++.dg/mv1.C: New test.
diff --git a/gcc/testsuite/gfortran.dg/transfer_class_1.f90 b/gcc/testsuite/gfortran.dg/transfer_class_1.f90
new file mode 100644
index 00000000000..00b3a2405f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_1.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-Wsurprising" }
+!
+! PR 54917: [4.7/4.8 Regression] [OOP] TRANSFER on polymorphic variable causes ICE
+!
+! Contributed by Sean Santos <quantheory@gmail.com>
+
+subroutine test_routine1(arg)
+  implicit none
+  type test_type
+    integer :: test_comp
+  end type
+  class(test_type) :: arg
+  integer :: i
+  i = transfer(arg, 1)
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/transfer_class_2.f90 b/gcc/testsuite/gfortran.dg/transfer_class_2.f90
new file mode 100644
index 00000000000..d75b640f10f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_2.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+! PR 54917: [OOP] TRANSFER on polymorphic variable causes ICE
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+  implicit none
+  type test_type
+    integer :: i = 0
+  contains
+    procedure :: ass
+    generic :: assignment(=) => ass
+  end type
+contains
+  subroutine ass (a, b)
+    class(test_type), intent(out) :: a
+    class(test_type), intent(in)  :: b
+    a%i = b%i
+  end subroutine
+end module
+
+
+program p
+  use m
+  implicit none
+
+  class(test_type), allocatable :: c
+  type(test_type) :: t
+
+  allocate(c)
+
+  ! (1) check CLASS-to-TYPE transfer
+  c%i=3
+  t = transfer(c, t)
+  if (t%i /= 3) call abort()
+
+  ! (2) check TYPE-to-CLASS transfer
+  t%i=4
+  c = transfer(t, c)
+  if (c%i /= 4) call abort()
+
+end
+
+! { dg-final { cleanup-modules "m" } }