gcc/testsuite/gfortran.dg/vector_subscript_1.f90

   1 ! PR 19239.  Check for various kinds of vector subscript.  In this test,
   2 ! all vector subscripts are indexing single-dimensional arrays.
   3 ! { dg-do run }
   4 program main
   5   implicit none
   6   integer, parameter :: n = 10
   7   integer :: i, j, calls
   8   integer, dimension (n) :: a, b, idx, id
   9
  10   idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /)
  11   id = (/ (i, i = 1, n) /)
  12   b = (/ (i * 100, i = 1, n) /)
  13
  14   !------------------------------------------------------------------
  15   ! Tests for a simple variable subscript
  16   !------------------------------------------------------------------
  17
  18   a (idx) = b
  19   call test (idx, id)
  20
  21   a = b (idx)
  22   call test (id, idx)
  23
  24   a (idx) = b (idx)
  25   call test (idx, idx)
  26
  27   !------------------------------------------------------------------
  28   ! Tests for constant ranges with non-default stride
  29   !------------------------------------------------------------------
  30
  31   a (idx (1:7:3)) = b (10:6:-2)
  32   call test (idx (1:7:3), id (10:6:-2))
  33
  34   a (10:6:-2) = b (idx (1:7:3))
  35   call test (id (10:6:-2), idx (1:7:3))
  36
  37   a (idx (1:7:3)) = b (idx (1:7:3))
  38   call test (idx (1:7:3), idx (1:7:3))
  39
  40   a (idx (1:7:3)) = b (idx (10:6:-2))
  41   call test (idx (1:7:3), idx (10:6:-2))
  42
  43   a (idx (10:6:-2)) = b (idx (10:6:-2))
  44   call test (idx (10:6:-2), idx (10:6:-2))
  45
  46   a (idx (10:6:-2)) = b (idx (1:7:3))
  47   call test (idx (10:6:-2), idx (1:7:3))
  48
  49   !------------------------------------------------------------------
  50   ! Tests for subscripts of the form CONSTRANGE + CONST
  51   !------------------------------------------------------------------
  52
  53   a (idx (1:5) + 1) = b (1:5)
  54   call test (idx (1:5) + 1, id (1:5))
  55
  56   a (1:5) = b (idx (1:5) + 1)
  57   call test (id (1:5), idx (1:5) + 1)
  58
  59   a (idx (6:10) - 1) = b (idx (1:5) + 1)
  60   call test (idx (6:10) - 1, idx (1:5) + 1)
  61
  62   !------------------------------------------------------------------
  63   ! Tests for variable subranges
  64   !------------------------------------------------------------------
  65
  66   do j = 5, 10
  67     a (idx (2:j:2)) = b (3:2+j/2)
  68     call test (idx (2:j:2), id (3:2+j/2))
  69
  70     a (3:2+j/2) = b (idx (2:j:2))
  71     call test (id (3:2+j/2), idx (2:j:2))
  72
  73     a (idx (2:j:2)) = b (idx (2:j:2))
  74     call test (idx (2:j:2), idx (2:j:2))
  75   end do
  76
  77   !------------------------------------------------------------------
  78   ! Tests for function vectors
  79   !------------------------------------------------------------------
  80
  81   calls = 0
  82
  83   a (foo (5, calls)) = b (2:10:2)
  84   call test (foo (5, calls), id (2:10:2))
  85
  86   a (2:10:2) = b (foo (5, calls))
  87   call test (id (2:10:2), foo (5, calls))
  88
  89   a (foo (5, calls)) = b (foo (5, calls))
  90   call test (foo (5, calls), foo (5, calls))
  91
  92   if (calls .ne. 8) call abort
  93
  94   !------------------------------------------------------------------
  95   ! Tests for constant vector constructors
  96   !------------------------------------------------------------------
  97
  98   a ((/ 1, 5, 3, 9 /)) = b (1:4)
  99   call test ((/ 1, 5, 3, 9 /), id (1:4))
 100
 101   a (1:4) = b ((/ 1, 5, 3, 9 /))
 102   call test (id (1:4), (/ 1, 5, 3, 9 /))
 103
 104   a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /))
 105   call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /))
 106
 107   !------------------------------------------------------------------
 108   ! Tests for variable vector constructors
 109   !------------------------------------------------------------------
 110
 111   do j = 1, 5
 112     a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j)
 113     call test ((/ 1, (i + 3, i = 2, j) /), id (1:j))
 114
 115     a (1:j) = b ((/ 1, (i + 3, i = 2, j) /))
 116     call test (id (1:j), (/ 1, (i + 3, i = 2, j) /))
 117
 118     a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /))
 119     call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /))
 120   end do
 121
 122   !------------------------------------------------------------------
 123   ! Tests in which the vector dimension is partnered by a temporary
 124   !------------------------------------------------------------------
 125
 126   calls = 0
 127   a (idx (1:6)) = foo (6, calls)
 128   if (calls .ne. 1) call abort
 129   do i = 1, 6
 130     if (a (idx (i)) .ne. i + 3) call abort
 131   end do
 132   a = 0
 133
 134   calls = 0
 135   a (idx (1:6)) = foo (6, calls) * 100
 136   if (calls .ne. 1) call abort
 137   do i = 1, 6
 138     if (a (idx (i)) .ne. (i + 3) * 100) call abort
 139   end do
 140   a = 0
 141
 142   a (idx) = id + 100
 143   do i = 1, n
 144     if (a (idx (i)) .ne. i + 100) call abort
 145   end do
 146   a = 0
 147
 148   a (idx (1:10:3)) = (/ 20, 10, 9, 11 /)
 149   if (a (idx (1)) .ne. 20) call abort
 150   if (a (idx (4)) .ne. 10) call abort
 151   if (a (idx (7)) .ne. 9) call abort
 152   if (a (idx (10)) .ne. 11) call abort
 153   a = 0
 154
 155 contains
 156   subroutine test (lhs, rhs)
 157     integer, dimension (:) :: lhs, rhs
 158     integer :: i
 159
 160     if (size (lhs, 1) .ne. size (rhs, 1)) call abort
 161     do i = 1, size (lhs, 1)
 162       if (a (lhs (i)) .ne. b (rhs (i))) call abort
 163     end do
 164     a = 0
 165   end subroutine test
 166
 167   function foo (n, calls)
 168     integer :: i, n, calls
 169     integer, dimension (n) :: foo
 170
 171     calls = calls + 1
 172     foo = (/ (i + 3, i = 1, n) /)
 173   end function foo
 174 end program main