re PR fortran/84074 (Incorrect indexing of array when actual argument is an array expression and dummy is polymorphic)

2018-02-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84074
	* trans-expr.c (gfc_conv_derived_to_class): Set the use_offset
	flag. If the is a vector subscript or the expression is not a
	variable, make the descriptor one-based.

2018-02-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84074
	* gfortran.dg/type_to_class_5.f03: New test.

From-SVN: r257564

4 files changed, 67 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b0bd14f..bebf155 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2018-02-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/84074
+	* trans-expr.c (gfc_conv_derived_to_class): Set the use_offset
+	flag. If the is a vector subscript or the expression is not a
+	variable, make the descriptor one-based.
+
 2018-02-10  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/84141
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7f790e7..a418582 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -547,6 +547,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
   tree ctree;
   tree var;
   tree tmp;
+  int dim;
 
   /* The derived type needs to be converted to a temporary
      CLASS object.  */
@@ -636,10 +637,34 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	{
 	  stmtblock_t block;
 	  gfc_init_block (&block);
+	  gfc_ref *ref;
 
 	  parmse->ss = ss;
+	  parmse->use_offset = 1;
 	  gfc_conv_expr_descriptor (parmse, e);
 
+	  /* Detect any array references with vector subscripts.  */
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_ARRAY
+		&& ref->u.ar.type != AR_ELEMENT
+		&& ref->u.ar.type != AR_FULL)
+	      {
+		for (dim = 0; dim < ref->u.ar.dimen; dim++)
+		  if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+		    break;
+		if (dim < ref->u.ar.dimen)
+		  break;
+	      }
+
+	  /* Array references with vector subscripts and non-variable expressions
+	     need be coverted to a one-based descriptor.  */
+	  if (ref || e->expr_type != EXPR_VARIABLE)
+	    {
+	      for (dim = 0; dim < e->rank; ++dim)
+		gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
+						  gfc_index_one_node);
+	    }
+
 	  if (e->rank != class_ts.u.derived->components->as->rank)
 	    {
 	      gcc_assert (class_ts.u.derived->components->as->type
@@ -10105,7 +10130,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   &expr1->where, msg);
 	}
 
-      /* Deallocate the lhs parameterized components if required.  */ 
+      /* Deallocate the lhs parameterized components if required.  */
       if (dealloc && expr2->expr_type == EXPR_FUNCTION
 	  && !expr1->symtree->n.sym->attr.associate_var)
 	{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a14db69..72b4e36 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-02-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/84074
+	* gfortran.dg/type_to_class_5.f03: New test.
+
 2018-02-10  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/56691
diff --git a/gcc/testsuite/gfortran.dg/type_to_class_5.f03 b/gcc/testsuite/gfortran.dg/type_to_class_5.f03
new file mode 100644
index 0000000..29a4b40
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/type_to_class_5.f03
@@ -0,0 +1,29 @@
+! { dg-do run }
+!
+! Test the fix for PR84074
+!
+! Contributed by Vladimir Fuka  <vladimir.fuka@gmail.com>
+!
+  type :: t
+      integer :: n
+  end type
+
+  type(t) :: array(4) = [t(1),t(2),t(3),t(4)]
+
+  call sub(array((/3,1/)), [3,1,0,0]) ! Does not increment any elements of 'array'.
+  call sub(array(1:3:2), [1,3,0,0])
+  call sub(array(3:1:-2), [4,2,0,0])
+  call sub(array, [3,2,5,4])          ! Elements 1 and 3 should have been incremented twice.
+
+contains
+
+  subroutine sub(a, iarray)
+    class(t) :: a(:)
+    integer :: iarray(4)
+    integer :: i
+    do i=1,size(a)
+        if (a(i)%n .ne. iarray(i)) call abort
+        a(i)%n = a(i)%n+1
+    enddo
+  end subroutine
+end program