re PR fortran/84074 (Incorrect indexing of array when actual argument is an array...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b0bd14f1839d6deac3f464ee9756239167fa709d..bebf155bfd0a1183210fe0b63ad7d8dfe00096f6 100644 (file)
--- 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 7f790e76a85bed1544e649d6bad2927b2456b30c..a4185820531f518a0ccd34d69c516eac696685e3 100644 (file)
--- 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 a14db69e416d8775232df4091c3774155d3420a4..72b4e36fd16e159cf053fe73dad87d4bb825d8fd 100644 (file)
--- 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 (file)
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