PR95331 - Unlimited polymorphic arrays have wrong bounds.

When iterating over a class array use the bounds provided by the
transformed descriptor (in sym->backend_decl) instead of the original
bounds of the array (in the descriptor passed in the class _data)
which are passed in se->expr.

The patch partially depends on the patch for PR52351 and PR85868, but
does not seems to break anything by itself.

gcc/fortran/ChangeLog:

2020-06-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

	PR fortran/95331
	* trans-array.c (gfc_conv_array_ref): For class array dummy
	arguments use the transformed descriptor in sym->backend_decl
	instead of the original descriptor.

gcc/testsuite/ChangeLog:

2020-06-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

	PR fortran/95331
	* gfortran.dg/PR95331.f90: New test.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3eb0e53e627e12636f860eab860a25c24b46314c..54e1107c71193e12421d0a6731aa8164ef807a73 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3672,8 +3672,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        }
     }
 
+  decl = se->expr;
+  if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED)
+    decl = sym->backend_decl;
+
   cst_offset = offset = gfc_index_zero_node;
-  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
+  add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
 
   /* Calculate the offsets from all the dimensions.  Make sure to associate
      the final offset so that we form a chain of loop invariant summands.  */
@@ -3694,7 +3698,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
          indexse.expr = save_expr (indexse.expr);
 
          /* Lower bound.  */
-         tmp = gfc_conv_array_lbound (se->expr, n);
+         tmp = gfc_conv_array_lbound (decl, n);
          if (sym->attr.temporary)
            {
              gfc_init_se (&tmpse, se);
@@ -3718,7 +3722,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
             arrays.  */
          if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
            {
-             tmp = gfc_conv_array_ubound (se->expr, n);
+             tmp = gfc_conv_array_ubound (decl, n);
              if (sym->attr.temporary)
                {
                  gfc_init_se (&tmpse, se);
@@ -3741,7 +3745,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        }
 
       /* Multiply the index by the stride.  */
-      stride = gfc_conv_array_stride (se->expr, n);
+      stride = gfc_conv_array_stride (decl, n);
       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
                             indexse.expr, stride);
 
@@ -3756,6 +3760,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   /* A pointer array component can be detected from its field decl. Fix
      the descriptor, mark the resulting variable decl and pass it to
      build_array_ref.  */
+  decl = NULL_TREE;
   if (get_CFI_desc (sym, expr, &decl, ar))
     decl = build_fold_indirect_ref_loc (input_location, decl);
   if (!expr->ts.deferred && !sym->attr.codimension

diff --git a/gcc/testsuite/gfortran.dg/PR95331.f90 b/gcc/testsuite/gfortran.dg/PR95331.f90
new file mode 100644 (file)
index 0000000..8024e79
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR95331.f90
@@ -0,0 +1,163 @@
+! { dg-do run }
+!
+! PR fortran/95331
+! 
+
+program main_p
+  
+  implicit none
+
+  integer, parameter :: n = 10
+  integer, parameter :: m = 5
+
+  integer, parameter :: b = 3
+  integer, parameter :: t = n+b-1
+  
+  integer, parameter :: l = 4
+  integer, parameter :: u = 7
+  integer, parameter :: s = 3
+  integer, parameter :: e = (u-l)/s+1
+  
+  call test_f()
+  call test_s()
+  call test_p()
+  call test_a()
+  stop
+
+contains
+
+  subroutine test_f()
+    integer :: x(n,n)
+    integer :: y(b:t)
+    integer :: i
+    
+    x = reshape([(i, i=1,n*n)], [n,n])
+    y = x(:,m)
+    call sub_s(x(:,m), y, n)
+    call sub_s(y, x(:,m), n)
+    return
+  end subroutine test_f
+  
+  subroutine test_s()
+    integer :: x(n,n)
+    integer :: v(e)
+    integer :: i
+    
+    x = reshape([(i, i=1,n*n)], [n,n])
+    v = x(l:u:s,m)
+    call sub_s(v, v, e)
+    call sub_s(x(l:u:s,m), v, e)
+    call sub_s(v, x(l:u:s,m), e)
+    return
+  end subroutine test_s
+  
+  subroutine test_p()
+    integer,  target :: x(n,n)
+    integer, pointer :: p(:)
+    integer          :: v(e)
+    integer          :: i
+    
+    x = reshape([(i, i=1,n*n)], [n,n])
+    v = x(l:u:s,m)
+    p => x(:,m)
+    call sub_s(p(l:u:s), v, e)
+    p => x(l:u:s,m)
+    call sub_s(p, v, e)
+    p(l:) => x(l:u:s,m)
+    call sub_s(p, v, e)
+    p(l:l+e-1) => x(l:u:s,m)
+    call sub_s(p, v, e)
+    allocate(p(n))
+    p(:) = x(:,m)
+    call sub_s(p(l:u:s), v, e)
+    deallocate(p)
+    allocate(p(e))
+    p(:) = x(l:u:s,m)
+    call sub_s(p, v, e)
+    deallocate(p)
+    allocate(p(l:l+e-1))
+    p(:) = x(l:u:s,m)
+    call sub_s(p, v, e)
+    deallocate(p)
+    allocate(p(l:l+e-1))
+    p(l:) = x(l:u:s,m)
+    call sub_s(p, v, e)
+    deallocate(p)
+    allocate(p(l:l+e-1))
+    p(l:l+e-1) = x(l:u:s,m)
+    call sub_s(p, v, e)
+    deallocate(p)
+    return
+  end subroutine test_p
+  
+  subroutine test_a()
+    integer              :: x(n,n)
+    integer, allocatable :: a(:)
+    integer              :: v(e)
+    integer              :: i
+    
+    x = reshape([(i, i=1,n*n)], [n,n])
+    v = x(l:u:s,m)
+    a = x(:,m)
+    call sub_s(a(l:u:s), v, e)
+    deallocate(a)
+    allocate(a(n))
+    a(:) = x(:,m)
+    call sub_s(a(l:u:s), v, e)
+    deallocate(a)
+    a = x(l:u:s,m)
+    call sub_s(a, v, e)
+    deallocate(a)
+    allocate(a(e))
+    a(:) = x(l:u:s,m)
+    call sub_s(a, v, e)
+    deallocate(a)
+    allocate(a(l:l+e-1))
+    a(:) = x(l:u:s,m)
+    call sub_s(a, v, e)
+    deallocate(a)
+    allocate(a(l:l+e-1))
+    a(l:) = x(l:u:s,m)
+    call sub_s(a, v, e)
+    deallocate(a)
+    allocate(a(l:l+e-1))
+    a(l:l+e-1) = x(l:u:s,m)
+    call sub_s(a, v, e)
+    deallocate(a)
+    return
+  end subroutine test_a
+
+  subroutine sub_s(a, b, n)
+    class(*), intent(in) :: a(:)
+    integer,  intent(in) :: b(:)
+    integer,  intent(in) :: n
+
+    integer :: i
+
+    if(lbound(a, dim=1)/=1) stop 1001
+    if(ubound(a, dim=1)/=n) stop 1002
+    if(any(shape(a)/=[n]))  stop 1003
+    if(size(a, dim=1)/=n)   stop 1004
+    if(size(a)/=size(b))    stop 1005
+    do i = 1, n
+      call vrfy(a(i), b(i))
+    end do
+    return
+  end subroutine sub_s
+
+  subroutine vrfy(a, b)
+    class(*), intent(in) :: a
+    integer,  intent(in) :: b
+
+    select type (a)
+    type is (integer)
+      !print *, a, b
+      if(a/=b) stop 2001
+    class default
+      STOP 2002
+    end select
+    return
+  end subroutine vrfy
+
+end program main_p
+