re PR fortran/66679 ([OOP] ICE with class(*) and transfer)

2018-08-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/66679
	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Class array
	elements are returned as references to the data element. Get
	the class expression by stripping back the references. Use this
	for the element size.

2018-08-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/66679
	* gfortran.dg/transfer_class_3.f90: New test.

From-SVN: r263499

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2d9c1f0ce572337a873201df429f5f5fd1c8d66b..6c39d9cc5d53ecd33bfda6b25b84caf3b8cf7725 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2018-08-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/66679
+       * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Class array
+       elements are returned as references to the data element. Get
+       the class expression by stripping back the references. Use this
+       for the element size.
+
 2018-08-12  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/86906

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c9b5479740c3f98f906132fda5c252274c4b6edd..db2bbab14123966ca99bcdc34d1f7afa286d7b84 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3664,8 +3664,8 @@ conv_intrinsic_random_init (gfc_code *code)
   gfc_add_block_to_block (&block, &se.post);
 
   /* Create the hidden argument.  For non-coarray codes and -fcoarray=single,
-     simply set this to 0.  For -fcoarray=lib, generate a call to 
-     THIS_IMAGE() without arguments.  */ 
+     simply set this to 0.  For -fcoarray=lib, generate a call to
+     THIS_IMAGE() without arguments.  */
   arg3 = build_int_cst (gfc_get_int_type (4), 0);
   if (flag_coarray == GFC_FCOARRAY_LIB)
     {
@@ -3677,7 +3677,7 @@ conv_intrinsic_random_init (gfc_code *code)
   tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3,
                             arg1, arg2, arg3);
   gfc_add_expr_to_block (&block, tmp);
- 
+
   return gfc_finish_block (&block);
 }
 
@@ -7369,13 +7369,14 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
   tree upper;
   tree lower;
   tree stmt;
+  tree class_ref = NULL_TREE;
   gfc_actual_arglist *arg;
   gfc_se argse;
   gfc_array_info *info;
   stmtblock_t block;
   int n;
   bool scalar_mold;
-  gfc_expr *source_expr, *mold_expr;
+  gfc_expr *source_expr, *mold_expr, *class_expr;
 
   info = NULL;
   if (se->loop)
@@ -7406,7 +7407,24 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     {
       gfc_conv_expr_reference (&argse, arg->expr);
       if (arg->expr->ts.type == BT_CLASS)
-       source = gfc_class_data_get (argse.expr);
+       {
+         tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
+         if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+           source = gfc_class_data_get (tmp);
+         else
+           {
+             /* Array elements are evaluated as a reference to the data.
+                To obtain the vptr for the element size, the argument
+                expression must be stripped to the class reference and
+                re-evaluated. The pre and post blocks are not needed.  */
+             gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+             source = argse.expr;
+             class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
+             gfc_init_se (&argse, NULL);
+             gfc_conv_expr (&argse, class_expr);
+             class_ref = argse.expr;
+           }
+       }
       else
        source = argse.expr;
 
@@ -7418,7 +7436,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
                                         argse.string_length);
          break;
        case BT_CLASS:
-         tmp = gfc_class_vtab_size_get (argse.expr);
+         if (class_ref != NULL_TREE)
+           tmp = gfc_class_vtab_size_get (class_ref);
+         else
+           tmp = gfc_class_vtab_size_get (argse.expr);
          break;
        default:
          source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index bced6d37d84979cb04a6d31296070c90ff650c48..95d558f2522043e0c6fefabe124826480ff5fd9e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-08-12  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/66679
+       * gfortran.dg/transfer_class_3.f90: New test.
+
 2018-08-12  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/86906

diff --git a/gcc/testsuite/gfortran.dg/transfer_class_3.f90 b/gcc/testsuite/gfortran.dg/transfer_class_3.f90
new file mode 100644 (file)
index 0000000..90082d7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_class_3.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+!
+! Test the fix for PR66679.
+!
+! Contributed by Miha Polajnar  <polajnar.miha@gmail.com>
+!
+program main
+  implicit none
+  class(*), allocatable :: vec(:)
+  integer :: var, ans(2)
+  allocate(vec(2),source=[1_4, 2_4])
+
+! This worked correctly.
+  if (any (transfer(vec,[var],2) .ne. [1_4, 2_4])) stop 1
+
+! This caused an ICE.
+  if (any ([transfer(vec(1),[var]), transfer(vec(2),[var])] .ne. [1_4, 2_4])) stop 2
+end program main