gcc/testsuite/gfortran.dg/array_reference_3.f90

   1 ! { dg-do run }
   2 ! { dg-additional-options "-fdump-tree-original" }
   3 !
   4 ! PR fortran/102043
   5 ! Array indexing was causing the middle-end to conclude the index
   6 ! to be non-negative, which can be wrong for arrays with a "reversed-order"
   7 ! descriptor.  This was fixed by using pointer arithmetic when
   8 ! the index can be negative.
   9 !
  10 ! This test checks the code generated for array references of various kinds
  11 ! of arrays, using either array indexing or pointer arithmetic.
  12
  13 program p
  14   implicit none
  15   call check_assumed_shape_elem
  16   call check_assumed_shape_scalarized
  17   call check_descriptor_dim
  18   call check_cfi_dim
  19   call check_substring
  20   call check_ptr_elem
  21   call check_ptr_scalarized
  22   call check_explicit_shape_elem
  23   call check_explicit_shape_scalarized
  24   call check_tmp_array
  25   call check_allocatable_array_elem
  26   call check_allocatable_array_scalarized
  27 contains
  28   subroutine cases(assumed_shape_x)
  29     integer :: assumed_shape_x(:)
  30     assumed_shape_x(2) = 10
  31   end subroutine cases
  32   subroutine check_assumed_shape_elem
  33     integer :: x(3)
  34     x = 0
  35     call cases(x)
  36     if (any(x /= (/ 0, 10, 0 /))) stop 10
  37     ! Assumed shape array are referenced with pointer arithmetic.
  38     ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_x.\\d+ \\+ \\(sizetype\\) \\(\\(stride.\\d+ \\* 2 \\+ offset.\\d+\\) \\* 4\\)\\) = 10;" 1 "original" } }
  39   end subroutine check_assumed_shape_elem
  40   subroutine casss(assumed_shape_y)
  41     integer :: assumed_shape_y(:)
  42     assumed_shape_y = 11
  43   end subroutine casss
  44   subroutine check_assumed_shape_scalarized
  45     integer :: y(3)
  46     call casss(y)
  47     if (any(y /= 11)) stop 11
  48     ! Assumed shape array are referenced with pointer arithmetic.
  49     ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_y.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 11;" 1 "original" } }
  50   end subroutine check_assumed_shape_scalarized
  51   subroutine check_descriptor_dim
  52     integer, allocatable :: descriptor(:)
  53     allocate(descriptor(4))
  54     descriptor(:) = 12
  55     if (any(descriptor /= 12)) stop 12
  56     ! The descriptor’s dim array is referenced with array indexing.
  57     ! { dg-final { scan-tree-dump-times "descriptor\\.dim\\\[0\\\]\\.ubound = 4;" 1 "original" } }
  58   end subroutine check_descriptor_dim
  59   subroutine ccfis(cfi_descriptor) bind(c)
  60     integer :: cfi_descriptor(:)
  61     cfi_descriptor = 13
  62   end subroutine ccfis
  63   subroutine check_cfi_dim
  64     integer :: x(5)
  65     call ccfis(x)
  66     if (any(x /= 13)) stop 13
  67     ! The cfi descriptor’s dim array is referenced with array indexing.
  68     ! { dg-final { scan-tree-dump-times "cfi_descriptor->dim\\\[idx.\\d+\\\]\\.ubound = _cfi_descriptor->dim\\\[idx.\\d+\\\]\\.extent \\+ \\(cfi_descriptor->dim\\\[idx.\\d+\\\]\\.lbound \\+ -1\\);" 1 "original" } }
  69   end subroutine check_cfi_dim
  70   subroutine css(c) bind(c)
  71     character :: c
  72     c = 'k'
  73   end subroutine css
  74   subroutine check_substring
  75     character(5) :: x
  76     x = 'abcde'
  77     call css(x(3:3))
  78     if (x /= 'abkde') stop 14
  79     ! Substrings use array indexing
  80     ! { dg-final { scan-tree-dump-times "css \\(\\(character\\(kind=1\\)\\\[\\d+:\\d+\\\] \\*\\) &x\\\[3\\\].lb: \\d+ sz: \\d+.\\);" 1 "original" } }
  81   end subroutine check_substring
  82   subroutine check_ptr_elem
  83     integer, target :: x(7)
  84     integer, pointer :: ptr_x(:)
  85     x = 0
  86     ptr_x => x
  87     ptr_x(4) = 16
  88     if (any(ptr_x /= (/ 0, 0, 0, 16, 0, 0, 0 /))) stop 16
  89     ! pointers are referenced with pointer arithmetic.
  90     ! { dg-final { scan-tree-dump-times "\\*\\(integer\\(kind=4\\) \\*\\) \\(ptr_x\\.data \\+ \\(sizetype\\) \\(\\(ptr_x\\.offset \\+ ptr_x\\.dim\\\[0\\\]\\.stride \\* 4\\) \\* ptr_x\\.span\\)\\) = 16;" 1 "original" } }
  91   end subroutine check_ptr_elem
  92   subroutine check_ptr_scalarized
  93     integer, target :: y(8)
  94     integer, pointer :: ptr_y(:)
  95     y = 0
  96     ptr_y => y
  97     ptr_y = 17
  98     if (any(ptr_y /= 17)) stop 17
  99     ! pointers are referenced with pointer arithmetic.
 100     ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) D.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* ptr_y\\.span\\)\\) = 17;" 1 "original" } }
 101   end subroutine check_ptr_scalarized
 102   subroutine check_explicit_shape_elem
 103     integer :: explicit_shape_x(9)
 104     explicit_shape_x = 0
 105     explicit_shape_x(5) = 18
 106     if (any(explicit_shape_x /= (/ 0, 0, 0, 0, 18, 0, 0, 0, 0 /))) stop 18
 107     ! Explicit shape arrays are referenced with array indexing.
 108     ! { dg-final { scan-tree-dump-times "explicit_shape_x\\\[4\\\] = 18;" 1 "original" } }
 109   end subroutine check_explicit_shape_elem
 110   subroutine check_explicit_shape_scalarized
 111     integer :: explicit_shape_y(3)
 112     explicit_shape_y = 19
 113     if (any(explicit_shape_y /= 19)) stop 19
 114     ! Explicit shape arrays are referenced with array indexing.
 115     ! { dg-final { scan-tree-dump-times "explicit_shape_y\\\[S.\\d+ \\+ -1\\\] = 19;" 1 "original" } }
 116   end subroutine check_explicit_shape_scalarized
 117   subroutine check_tmp_array
 118     integer :: non_tmp(6)
 119     non_tmp = 15
 120     non_tmp(2:5) = non_tmp(1:4) + non_tmp(3:6)
 121     if (any(non_tmp /= (/ 15, 30, 30, 30, 30, 15 /))) stop 15
 122     ! temporary arrays use array indexing
 123     ! { dg-final { scan-tree-dump-times "\\(*\\(integer\\(kind=4\\)\\\[4\\\] \\* restrict\\) atmp.\\d+\\.data\\)\\\[S.\\d+\\\] = non_tmp\\\[S.\\d+\\\] \\+ non_tmp\\\[S.\\d+ \\+ 2\\\];" 1 "original" } }
 124     ! { dg-final { scan-tree-dump-times "non_tmp\\\[S.\\d+ \\+ 1\\\] = \\(\\*\\(integer\\(kind=4\\)\\\[4\\\] \\* restrict\\) atmp.\\d+\\.data\\)\\\[S.\\d+\\\];" 1 "original" } }
 125   end subroutine check_tmp_array
 126   subroutine check_allocatable_array_elem
 127     integer, allocatable :: allocatable_x(:)
 128     allocate(allocatable_x(4),source=0)
 129     allocatable_x(2) = 20
 130     if (any(allocatable_x /= (/ 0, 20, 0, 0 /))) stop 20
 131     ! Allocatable arrays are referenced with array indexing.
 132     ! { dg-final { scan-tree-dump-times "\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) allocatable_x\\.data\\)\\\[allocatable_x\\.offset \\+ 2\\\] = 20;" 1 "original" } }
 133   end subroutine check_allocatable_array_elem
 134   subroutine check_allocatable_array_scalarized
 135     integer, allocatable :: allocatable_y(:)
 136     allocate(allocatable_y(5),source=0)
 137     allocatable_y = 21
 138     if (any(allocatable_y /= 21)) stop 21
 139     ! Allocatable arrays are referenced with array indexing.
 140     ! { dg-final { scan-tree-dump-times "\\(\\*D.\\d+\\)\\\[S.\\d+ \\+ \\D.\\d+\\\] = 21;" 1 "original" } }
 141   end subroutine check_allocatable_array_scalarized
 142   subroutine cares(assumed_rank_x)
 143     integer :: assumed_rank_x(..)
 144     select rank(rank_1_var_x => assumed_rank_x)
 145       rank(1)
 146         rank_1_var_x(3) = 22
 147     end select
 148   end subroutine cares
 149   subroutine check_assumed_rank_elem
 150     integer :: x(6)
 151     x = 0
 152     call cares(x)
 153     if (any(x /= (/ 0, 0, 22, 0, 0, 0 /))) stop 22
 154     ! Assumed rank arrays are referenced with pointer arithmetic.
 155     ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) __tmp_INTEGER_4_rank_1\\.data \\+ \\(sizetype\\) \\(\\(__tmp_INTEGER_4_rank_1\\.offset \\+ __tmp_INTEGER_4_rank_1\\.dim\\\[0\\\]\\.stride \\* 3\\) \\* 4\\)\\) = 22;" 1 "original" } }
 156   end subroutine check_assumed_rank_elem
 157   subroutine carss(assumed_rank_y)
 158     integer :: assumed_rank_y(..)
 159     select rank(rank_1_var_y => assumed_rank_y)
 160       rank(1)
 161         rank_1_var_y = 23
 162     end select
 163   end subroutine carss
 164   subroutine check_assumed_rank_scalarized
 165     integer :: y(7)
 166     call carss(y)
 167     if (any(y /= 23)) stop 23
 168     ! Assumed rank arrays are referenced with pointer arithmetic.
 169     ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) D.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 23;" 1 "original" } }
 170   end subroutine check_assumed_rank_scalarized
 171   subroutine casces(assumed_shape_cont_x)
 172     integer, dimension(:), contiguous :: assumed_shape_cont_x
 173     assumed_shape_cont_x(4) = 24
 174   end subroutine casces
 175   subroutine check_assumed_shape_cont_elem
 176     integer :: x(8)
 177     x = 0
 178     call casces(x)
 179     if (any(x /= (/ 0, 0, 0, 24, 0, 0, 0, 0 /))) stop 24
 180     ! Contiguous assumed shape arrays are referenced with array indexing.
 181     ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_cont_x.\\d+\\)\\\[stride.\\d+ \\* 4 \\+ offset.\\d+\\\] = 24;" 1 "original" } }
 182   end subroutine check_assumed_shape_cont_elem
 183   subroutine cascss(assumed_shape_cont_y)
 184     integer, dimension(:), contiguous :: assumed_shape_cont_y
 185     assumed_shape_cont_y = 25
 186   end subroutine cascss
 187   subroutine check_assumed_shape_cont_scalarized
 188     integer :: y(9)
 189     call cascss(y)
 190     if (any(y /= 25)) stop 25
 191     ! Contiguous assumed shape arrays are referenced with array indexing.
 192     ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_cont_y.\\d+\\)\\\[S.\\d+ \\* D.\\d+ \\+ D.\\d+\\\] = 25;" 1 "original" } }
 193   end subroutine check_assumed_shape_cont_scalarized
 194 end program p
 195