Hi all!
Proposed patch to PR95331 - Unlimited polymorphic arrays have wrong bounds.
Patch tested only on x86_64-pc-linux-gnu.
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.
Not sure if this is the best solution, but at least it identifies the
problem.
Thank you very much.
Best regards,
José Rui
2020-5-26 José Rui Faustino de Sousa <jrfso...@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.
2020-5-26 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/95331
* PR95331.f90: New test.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 434960c..f44a986 100644
--- 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
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
+
