gcc/testsuite/gfortran.dg/finalize_13.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/37336
   4 !
   5 module m
   6   implicit none
   7   type t
   8     integer :: i
   9   contains
  10     final :: fini3, fini2, fini_elm
  11   end type t
  12
  13   type, extends(t) :: t2
  14     integer :: j
  15   contains
  16     final :: f2ini2, f2ini_elm
  17   end type t2
  18
  19   logical :: elem_call
  20   logical :: rank2_call
  21   logical :: rank3_call
  22   integer :: cnt, cnt2
  23   integer :: fini_call
  24
  25 contains
  26   subroutine fini2 (x)
  27     type(t), intent(in), contiguous :: x(:,:)
  28     if (.not. rank2_call) call abort ()
  29     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
  30     !print *, 'fini2:', x%i
  31     if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
  32     fini_call = fini_call + 1
  33   end subroutine
  34
  35   subroutine fini3 (x)
  36     type(t), intent(in) :: x(2,2,*)
  37     integer :: i,j,k
  38     if (.not. elem_call) call abort ()
  39     if (.not. rank3_call) call abort ()
  40     if (cnt2 /= 9) call abort()
  41     if (cnt /= 1) call abort()
  42       do i = 1, 2
  43         do j = 1, 2
  44           do k = 1, 2
  45             !print *, k,j,i,x(k,j,i)%i
  46             if (x(k,j,i)%i /= k+10*j+100*i) call abort()
  47           end do
  48         end do
  49       end do
  50     fini_call = fini_call + 1
  51   end subroutine
  52
  53   impure elemental subroutine fini_elm (x)
  54     type(t), intent(in) :: x
  55     if (.not. elem_call) call abort ()
  56     if (rank3_call) call abort ()
  57     if (cnt2 /= 6) call abort()
  58     if (cnt /= x%i) call abort()
  59     !print *, 'fini_elm:', cnt, x%i
  60     fini_call = fini_call + 1
  61     cnt = cnt + 1
  62   end subroutine
  63
  64   subroutine f2ini2 (x)
  65     type(t2), intent(in), target :: x(:,:)
  66     if (.not. rank2_call) call abort ()
  67     if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
  68     !print *, 'f2ini2:', x%i
  69     !print *, 'f2ini2:', x%j
  70     if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
  71     if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
  72     fini_call = fini_call + 1
  73   end subroutine
  74
  75   impure elemental subroutine f2ini_elm (x)
  76     type(t2), intent(in) :: x
  77     integer, parameter :: exprected(*) &
  78             = [111, 112, 121, 122, 211, 212, 221, 222]
  79
  80     if (.not. elem_call) call abort ()
  81     !print *, 'f2ini_elm:', cnt2, x%i, x%j
  82     if (rank3_call) then
  83       if (x%i /= exprected(cnt2)) call abort ()
  84       if (x%j /= 1000*exprected(cnt2)) call abort ()
  85     else
  86       if (cnt2 /= x%i .or. cnt2*10 /= x%j) call abort()
  87     end if
  88     cnt2 = cnt2 + 1
  89     fini_call = fini_call + 1
  90   end subroutine
  91 end module m
  92
  93
  94 program test
  95   use m
  96   implicit none
  97   class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:)
  98   target :: z, zz
  99   integer :: i,j,k
 100
 101   elem_call = .false.
 102   rank2_call = .false.
 103   rank3_call = .false.
 104   allocate (t2 :: y(5))
 105   select type (y)
 106     type is (t2)
 107       do i = 1, 5
 108         y(i)%i = i
 109         y(i)%j = i*10
 110       end do
 111   end select
 112   cnt = 1
 113   cnt2 = 1
 114   fini_call = 0
 115   elem_call = .true.
 116   deallocate (y)
 117   if (fini_call /= 10) call abort ()
 118
 119   elem_call = .false.
 120   rank2_call = .false.
 121   rank3_call = .false.
 122   allocate (t2 :: z(2,3))
 123   select type (z)
 124     type is (t2)
 125       do i = 1, 3
 126         do j = 1, 2
 127           z(j,i)%i = j+10*i
 128           z(j,i)%j = (j+10*i)*100
 129         end do
 130       end do
 131   end select
 132   cnt = 1
 133   cnt2 = 1
 134   fini_call = 0
 135   rank2_call = .true.
 136   deallocate (z)
 137   if (fini_call /= 2) call abort ()
 138
 139   elem_call = .false.
 140   rank2_call = .false.
 141   rank3_call = .false.
 142   allocate (t2 :: zz(2,2,2))
 143   select type (zz)
 144     type is (t2)
 145       do i = 1, 2
 146         do j = 1, 2
 147           do k = 1, 2
 148             zz(k,j,i)%i = k+10*j+100*i
 149             zz(k,j,i)%j = (k+10*j+100*i)*1000
 150           end do
 151         end do
 152       end do
 153   end select
 154   cnt = 1
 155   cnt2 = 1
 156   fini_call = 0
 157   rank3_call = .true.
 158   elem_call = .true.
 159   deallocate (zz)
 160   if (fini_call /= 2*2*2+1) call abort ()
 161 end program test