gcc/testsuite/gfortran.dg/finalize_15.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/37336
   4 !
   5 ! Check the scalarizer/array packing with strides
   6 ! in the finalization wrapper
   7 !
   8 module m
   9   implicit none
  10
  11   type t1
  12     integer :: i = 1
  13   contains
  14     final :: fini_elem
  15   end type t1
  16
  17   type, extends(t1) :: t1e
  18     integer :: j = 11
  19   contains
  20     final :: fini_elem2
  21   end type t1e
  22
  23   type t2
  24     integer :: i = 2
  25   contains
  26     final :: fini_shape
  27   end type t2
  28
  29   type, extends(t2) :: t2e
  30     integer :: j = 22
  31   contains
  32     final :: fini_shape2
  33   end type t2e
  34
  35   type t3
  36     integer :: i = 3
  37   contains
  38     final :: fini_explicit
  39   end type t3
  40
  41   type, extends(t3) :: t3e
  42     integer :: j = 33
  43   contains
  44     final :: fini_explicit2
  45   end type t3e
  46
  47   integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e
  48
  49 contains
  50
  51   impure elemental subroutine fini_elem(x)
  52     type(t1), intent(inout) :: x
  53     integer :: i, j, i2, j2
  54
  55     if (cnt1e /= 5*4) STOP 1
  56     j = mod (cnt1,5)+1
  57     i = cnt1/5 + 1
  58     i2 = (i-1)*3 + 1
  59     j2 = (j-1)*2 + 1
  60     if (x%i /= j2 + 100*i2) STOP 2
  61     x%i = x%i * (-13)
  62     cnt1 = cnt1 + 1
  63   end subroutine fini_elem
  64
  65   impure elemental subroutine fini_elem2(x)
  66     type(t1e), intent(inout) :: x
  67     integer :: i, j, i2, j2
  68
  69     j = mod (cnt1e,5)+1
  70     i = cnt1e/5 + 1
  71     i2 = (i-1)*3 + 1
  72     j2 = (j-1)*2 + 1
  73     if (x%i /= j2 + 100*i2) STOP 3
  74     if (x%j /= (j2 + 100*i2)*100) STOP 4
  75     x%j = x%j * (-13)
  76     cnt1e = cnt1e + 1
  77   end subroutine fini_elem2
  78
  79   subroutine fini_shape(x)
  80     type(t2) :: x(:,:)
  81     if (cnt2e /= 1 .or. cnt2 /= 0) STOP 5
  82     call check_var_sec(x%i, 1)
  83     x%i = x%i * (-13)
  84     cnt2 = cnt2 + 1
  85   end subroutine fini_shape
  86
  87   subroutine fini_shape2(x)
  88     type(t2e) :: x(:,:)
  89     call check_var_sec(x%i, 1)
  90     call check_var_sec(x%j, 100)
  91     x%j = x%j * (-13)
  92     cnt2e = cnt2e + 1
  93   end subroutine fini_shape2
  94
  95   subroutine fini_explicit(x)
  96     type(t3) :: x(5,4)
  97     if (cnt3e /= 1 .or. cnt3 /= 0) STOP 6
  98     call check_var_sec(x%i, 1)
  99     x%i = x%i * (-13)
 100     cnt3 = cnt3 + 1
 101   end subroutine fini_explicit
 102
 103   subroutine fini_explicit2(x)
 104     type(t3e) :: x(5,4)
 105     call check_var_sec(x%i, 1)
 106     call check_var_sec(x%j, 100)
 107     x%j = x%j * (-13)
 108     cnt3e = cnt3e + 1
 109   end subroutine fini_explicit2
 110
 111   subroutine fin_test_1(x)
 112     class(t1), intent(out) :: x(5,4)
 113   end subroutine fin_test_1
 114
 115   subroutine fin_test_2(x)
 116     class(t2), intent(out) :: x(:,:)
 117   end subroutine fin_test_2
 118
 119   subroutine fin_test_3(x)
 120     class(t3), intent(out) :: x(:,:)
 121     if (any (shape(x) /= [5,4])) STOP 7
 122   end subroutine fin_test_3
 123
 124   subroutine check_var_sec(x, factor)
 125     integer :: x(:,:)
 126     integer, value :: factor
 127     integer :: i, j, i2, j2
 128
 129     do i = 1, 4
 130       i2 = (i-1)*3 + 1
 131       do j = 1, 5
 132         j2 = (j-1)*2 + 1
 133         if (x(j,i) /= (j2 + 100*i2)*factor) STOP 8
 134       end do
 135     end do
 136   end subroutine check_var_sec
 137 end module m
 138
 139
 140 program test
 141   use m
 142   implicit none
 143
 144   class(t1), allocatable :: x(:,:)
 145   class(t2), allocatable :: y(:,:)
 146   class(t3), allocatable :: z(:,:)
 147   integer :: i, j
 148
 149   cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0;  cnt3 = 0; cnt3e = 0
 150
 151   allocate (t1e :: x(10,10))
 152   allocate (t2e :: y(10,10))
 153   allocate (t3e :: z(10,10))
 154
 155   select type(x)
 156     type is (t1e)
 157       do i = 1, 10
 158         do j = 1, 10
 159           x(j,i)%i = j + 100*i
 160           x(j,i)%j = (j + 100*i)*100
 161         end do
 162       end do
 163   end select
 164
 165   select type(y)
 166     type is (t2e)
 167       do i = 1, 10
 168         do j = 1, 10
 169           y(j,i)%i = j + 100*i
 170           y(j,i)%j = (j + 100*i)*100
 171         end do
 172       end do
 173   end select
 174
 175   select type(z)
 176     type is (t3e)
 177       do i = 1, 10
 178         do j = 1, 10
 179           z(j,i)%i = j + 100*i
 180           z(j,i)%j = (j + 100*i)*100
 181         end do
 182       end do
 183   end select
 184
 185   if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) STOP 9
 186
 187   call fin_test_1(x(::2,::3))
 188   if (cnt1 /= 5*4) STOP 10
 189   if (cnt1e /= 5*4) STOP 11
 190   cnt1 = 0; cnt1e = 0
 191   if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) STOP 12
 192
 193   call fin_test_2(y(::2,::3))
 194   if (cnt2 /= 1) STOP 13
 195   if (cnt2e /= 1) STOP 14
 196   cnt2 = 0; cnt2e = 0
 197   if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) STOP 15
 198
 199   call fin_test_3(z(::2,::3))
 200   if (cnt3 /= 1) STOP 16
 201   if (cnt3e /= 1) STOP 17
 202   cnt3 = 0; cnt3e = 0
 203   if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) STOP 18
 204
 205   select type(x)
 206     type is (t1e)
 207       call check_val(x%i, 1, 1)
 208       call check_val(x%j, 100, 11)
 209   end select
 210
 211   select type(y)
 212     type is (t2e)
 213       call check_val(y%i, 1, 2)
 214       call check_val(y%j, 100, 22)
 215   end select
 216
 217   select type(z)
 218     type is (t3e)
 219       call check_val(z%i, 1, 3)
 220       call check_val(z%j, 100, 33)
 221   end select
 222
 223 contains
 224   subroutine check_val(x, factor, val)
 225     integer :: x(:,:)
 226     integer, value :: factor, val
 227     integer :: i, j
 228     do i = 1, 10
 229       do j = 1, 10
 230         if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
 231           if (x(j,i) /= val) STOP 19
 232         else
 233           if (x(j,i) /= (j + 100*i)*factor) STOP 20
 234         end if
 235       end do
 236     end do
 237   end subroutine check_val
 238 end program test