libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90

   1 ! { dg-do run }
   2
   3 ! Like imperfect2.f90, but adds bindings to the blocks.
   4
   5 module m
   6   implicit none
   7   type t
   8       integer :: i
   9     contains
  10       final :: fini
  11   end type t
  12
  13   integer :: ccount(3), dcount(3)
  14
  15   contains
  16
  17     subroutine init(x, n)
  18       type(t) :: x
  19       integer :: n
  20       x%i = n
  21       ccount(x%i) = ccount(x%i) + 1
  22     end subroutine init
  23
  24     subroutine fini(x)
  25       type(t) :: x
  26       dcount(x%i) = dcount(x%i) + 1
  27     end subroutine fini
  28 end module m
  29
  30 program foo
  31   use m
  32
  33   integer :: f1count(3), f2count(3), g1count(3), g2count(3)
  34
  35   f1count(1) = 0
  36   f1count(2) = 0
  37   f1count(3) = 0
  38   f2count(1) = 0
  39   f2count(2) = 0
  40   f2count(3) = 0
  41
  42   g1count(1) = 0
  43   g1count(2) = 0
  44   g1count(3) = 0
  45   g2count(1) = 0
  46   g2count(2) = 0
  47   g2count(3) = 0
  48
  49   call s1 (3, 4, 5)
  50
  51   ! All intervening code at the same depth must be executed the same
  52   ! number of times.
  53   if (f1count(1) /= f2count(1)) error stop 101
  54   if (f1count(2) /= f2count(2)) error stop 102
  55   if (f1count(3) /= f2count(3)) error stop 103
  56   if (g1count(1) /= f1count(1)) error stop 104
  57   if (g2count(1) /= f1count(1)) error stop 105
  58   if (g1count(2) /= f1count(2)) error stop 106
  59   if (g2count(2) /= f1count(2)) error stop 107
  60   if (g1count(3) /= f1count(3)) error stop 108
  61   if (g2count(3) /= f1count(3)) error stop 109
  62
  63   ! Intervening code must be executed at least as many times as the loop
  64   ! that encloses it.
  65   if (f1count(1) < 3) error stop 111
  66   if (f1count(2) < 3 * 4) error stop 112
  67
  68   ! Intervening code must not be executed more times than the number
  69   ! of logical iterations.
  70   if (f1count(1) > 3 * 4 * 5) error stop 121
  71   if (f1count(2) > 3 * 4 * 5) error stop 122
  72
  73   ! Check that the innermost loop body is executed exactly the number
  74   ! of logical iterations expected.
  75   if (f1count(3) /= 3 * 4 * 5) error stop 131
  76
  77   ! Check that constructors and destructors are called equal number of times.
  78   if (ccount(1) /= dcount(1)) error stop 141
  79   if (ccount(2) /= dcount(2)) error stop 142
  80   if (ccount(3) /= dcount(3)) error stop 143
  81
  82 contains
  83
  84 subroutine f1 (depth, iter)
  85   integer :: depth, iter
  86   f1count(depth) = f1count(depth) + 1
  87 end subroutine
  88
  89 subroutine f2 (depth, iter)
  90   integer :: depth, iter
  91   f2count(depth) = f2count(depth) + 1
  92 end subroutine
  93
  94 subroutine g1 (depth, iter)
  95   integer :: depth, iter
  96   g1count(depth) = g1count(depth) + 1
  97 end subroutine
  98
  99 subroutine g2 (depth, iter)
 100   integer :: depth, iter
 101   g2count(depth) = g2count(depth) + 1
 102 end subroutine
 103
 104 subroutine s1 (a1, a2, a3)
 105   integer :: a1, a2, a3
 106   integer :: i, j, k
 107
 108   !$omp do collapse(3)
 109   do i = 1, a1
 110     call f1 (1, i)
 111     block
 112       type (t) :: local1
 113       call init (local1, 1)
 114       call g1 (local1%i, i)
 115       do j = 1, a2
 116         call f1 (2, j)
 117         block
 118           type (t) :: local2
 119           call init (local2, 2)
 120           call g1 (local2%i, j)
 121           do k = 1, a3
 122             call f1 (3, k)
 123             block
 124               type (t) :: local3
 125               call init (local3, 3)
 126               call g1 (local3%i, k)
 127               call g2 (local3%i, k)
 128             end block
 129             call f2 (3, k)
 130           end do
 131           call g2 (local2%i, j)
 132         end block
 133         call f2 (2, j)
 134       end do
 135       call g2 (local1%i, i)
 136     end block
 137     call f2 (1, i)
 138   end do
 139
 140 end subroutine
 141
 142 end program