From: José Rui Faustino de Sousa Date: Thu, 11 Jun 2020 13:15:25 +0000 (+0200) Subject: PR95331 - Unlimited polymorphic arrays have wrong bounds. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2ee70f5d161edd99a7af97d166b251bcf83cd91b;p=gcc.git 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 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 PR fortran/95331 * gfortran.dg/PR95331.f90: New test. --- diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 3eb0e53e627..54e1107c711 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 00000000000..8024e79fed5 --- /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 +