1! { dg-do run } 2! { dg-options "-fcoarray=single" } 3! 4! PR fortran/37336 5! 6module m 7 implicit none 8 type t 9 integer :: i 10 contains 11 final :: fini, fini2 12 end type t 13 integer :: global_count1, global_count2 14contains 15 subroutine fini(x) 16 type(t) :: x 17 !print *, 'fini:',x%i 18 if (global_count1 == -1) STOP 1 19 if (x%i /= 42) STOP 2 20 x%i = 33 21 global_count1 = global_count1 + 1 22 end subroutine fini 23 subroutine fini2(x) 24 type(t) :: x(:) 25 !print *, 'fini2', x%i 26 if (global_count2 == -1) STOP 3 27 if (size(x) /= 5) STOP 4 28 if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) STOP 5 29 x%i = 33 30 global_count2 = global_count2 + 10 31 end subroutine fini2 32end module m 33 34program pp 35 use m 36 implicit none 37 type(t), allocatable :: ya 38 class(t), allocatable :: yc 39 type(t), allocatable :: yaa(:) 40 class(t), allocatable :: yca(:) 41 42 type(t), allocatable :: ca[:] 43 class(t), allocatable :: cc[:] 44 type(t), allocatable :: caa(:)[:] 45 class(t), allocatable :: cca(:)[:] 46 47 global_count1 = -1 48 global_count2 = -1 49 allocate (ya, yc, yaa(5), yca(5)) 50 global_count1 = 0 51 global_count2 = 0 52 ya%i = 42 53 yc%i = 42 54 yaa%i = [1,2,3,4,5] 55 yca%i = [1,2,3,4,5] 56 57 call foo(ya, yc, yaa, yca) 58 if (global_count1 /= 2) STOP 6 59 if (global_count2 /= 20) STOP 7 60 61 ! Coarray finalization 62 allocate (ca[*], cc[*], caa(5)[*], cca(5)[*]) 63 global_count1 = 0 64 global_count2 = 0 65 ca%i = 42 66 cc%i = 42 67 caa%i = [1,2,3,4,5] 68 cca%i = [1,2,3,4,5] 69 deallocate (ca, cc, caa, cca) 70 if (global_count1 /= 2) STOP 8 71 if (global_count2 /= 20) STOP 9 72 global_count1 = -1 73 global_count2 = -1 74 75 block 76 type(t), allocatable :: za 77 class(t), allocatable :: zc 78 type(t), allocatable :: zaa(:) 79 class(t), allocatable :: zca(:) 80 81 ! Test intent(out) finalization 82 allocate (za, zc, zaa(5), zca(5)) 83 global_count1 = 0 84 global_count2 = 0 85 za%i = 42 86 zc%i = 42 87 zaa%i = [1,2,3,4,5] 88 zca%i = [1,2,3,4,5] 89 90 call foo(za, zc, zaa, zca) 91 if (global_count1 /= 2) STOP 10 92 if (global_count2 /= 20) STOP 11 93 94 ! Test intent(out) finalization with optional 95 call foo_opt() 96 call opt() 97 98 ! Test intent(out) finalization with optional 99 allocate (za, zc, zaa(5), zca(5)) 100 global_count1 = 0 101 global_count2 = 0 102 za%i = 42 103 zc%i = 42 104 zaa%i = [1,2,3,4,5] 105 zca%i = [1,2,3,4,5] 106 107 call foo_opt(za, zc, zaa, zca) 108 if (global_count1 /= 2) STOP 12 109 if (global_count2 /= 20) STOP 13 110 111 ! Test DEALLOCATE finalization 112 allocate (za, zc, zaa(5), zca(5)) 113 global_count1 = 0 114 global_count2 = 0 115 za%i = 42 116 zc%i = 42 117 zaa%i = [1,2,3,4,5] 118 zca%i = [6,7,8,9,10] 119 deallocate (za, zc, zaa, zca) 120 if (global_count1 /= 2) STOP 14 121 if (global_count2 /= 20) STOP 15 122 123 ! Test end-of-scope finalization 124 allocate (za, zc, zaa(5), zca(5)) 125 global_count1 = 0 126 global_count2 = 0 127 za%i = 42 128 zc%i = 42 129 zaa%i = [1,2,3,4,5] 130 zca%i = [6,7,8,9,10] 131 end block 132 133 if (global_count1 /= 2) STOP 16 134 if (global_count2 /= 20) STOP 17 135 136 ! Test that no end-of-scope finalization occurs 137 ! for SAVED variable in main 138 allocate (ya, yc, yaa(5), yca(5)) 139 global_count1 = -1 140 global_count2 = -1 141 142contains 143 144 subroutine opt(xa, xc, xaa, xca) 145 type(t), allocatable, optional :: xa 146 class(t), allocatable, optional :: xc 147 type(t), allocatable, optional :: xaa(:) 148 class(t), allocatable, optional :: xca(:) 149 call foo_opt(xc, xc, xaa) 150 !call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445 151 end subroutine opt 152 subroutine foo_opt(xa, xc, xaa, xca) 153 type(t), allocatable, intent(out), optional :: xa 154 class(t), allocatable, intent(out), optional :: xc 155 type(t), allocatable, intent(out), optional :: xaa(:) 156 class(t), allocatable, intent(out), optional :: xca(:) 157 158 if (.not. present(xa)) & 159 return 160 if (allocated (xa)) STOP 18 161 if (allocated (xc)) STOP 19 162 if (allocated (xaa)) STOP 20 163 if (allocated (xca)) STOP 21 164 end subroutine foo_opt 165 subroutine foo(xa, xc, xaa, xca) 166 type(t), allocatable, intent(out) :: xa 167 class(t), allocatable, intent(out) :: xc 168 type(t), allocatable, intent(out) :: xaa(:) 169 class(t), allocatable, intent(out) :: xca(:) 170 if (allocated (xa)) STOP 22 171 if (allocated (xc)) STOP 23 172 if (allocated (xaa)) STOP 24 173 if (allocated (xca)) STOP 25 174 end subroutine foo 175end program 176