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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 084f1f8..f33dffb 100644 (file)
--- 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 aec7fa2..437a3df 100644 (file)
--- 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 4b268b3..b101cb4 100644 (file)
--- 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 e44a637..c4d388d 100644 (file)
--- 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 (file)
index 0000000..00b3a24
--- /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 (file)
index 0000000..d75b640
--- /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" } }