gcc/testsuite/gfortran.dg/finalize_38a.f90

   1 ! { dg-do run }
   2 ! { dg-options "-std=f2008" }
   3 !
   4 ! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
   5 ! With -std=f2008, structure and array constructors are finalized.
   6 ! See finalize_38.f90 for the result with -std=gnu.
   7 ! Tests fix for PR64290 as well.
   8 !
   9 module testmode
  10   implicit none
  11
  12   type :: simple
  13     integer :: ind
  14   contains
  15     final :: destructor1, destructor2
  16   end type simple
  17
  18   type, extends(simple) :: complicated
  19     real :: rind
  20   contains
  21     final :: destructor3, destructor4
  22   end type complicated
  23
  24   integer :: check_scalar
  25   integer :: check_array(4)
  26   real :: check_real
  27   real :: check_rarray(4)
  28   integer :: final_count = 0
  29   integer :: fails = 0
  30
  31 contains
  32
  33   subroutine destructor1(self)
  34     type(simple), intent(inout) :: self
  35     check_scalar = self%ind
  36     check_array = 0
  37     final_count = final_count + 1
  38   end subroutine destructor1
  39
  40   subroutine destructor2(self)
  41     type(simple), intent(inout) :: self(:)
  42     check_scalar = 0
  43     check_array(1:size(self, 1)) = self%ind
  44     final_count = final_count + 1
  45   end subroutine destructor2
  46
  47   subroutine destructor3(self)
  48     type(complicated), intent(inout) :: self
  49     check_real = self%rind
  50     check_array = 0.0
  51     final_count = final_count + 1
  52   end subroutine destructor3
  53
  54   subroutine destructor4(self)
  55     type(complicated), intent(inout) :: self(:)
  56     check_real = 0.0
  57     check_rarray(1:size(self, 1)) = self%rind
  58     final_count = final_count + 1
  59   end subroutine destructor4
  60
  61   function constructor1(ind) result(res)
  62     class(simple), allocatable :: res
  63     integer, intent(in) :: ind
  64     allocate (res, source = simple (ind))
  65   end function constructor1
  66
  67   function constructor2(ind, rind) result(res)
  68     class(simple), allocatable :: res(:)
  69     integer, intent(in) :: ind(:)
  70     real, intent(in), optional :: rind(:)
  71     type(complicated), allocatable :: src(:)
  72     integer :: sz
  73     integer :: i
  74     if (present (rind)) then
  75       sz = min (size (ind, 1), size (rind, 1))
  76       src  = [(complicated (ind(i), rind(i)), i = 1, sz)]  ! { dg-warning "has been finalized" }
  77       allocate (res, source = src)
  78     else
  79       sz = size (ind, 1)
  80       allocate (res, source = [(simple (ind(i)), i = 1, sz)])
  81     end if
  82   end function constructor2
  83
  84   subroutine test (cnt, scalar, array, off, rind, rarray)
  85     integer :: cnt
  86     integer :: scalar
  87     integer :: array(:)
  88     integer :: off
  89     real, optional :: rind
  90     real, optional :: rarray(:)
  91     if (final_count .ne. cnt) then
  92         print *, 1 + off, final_count, '(', cnt, ')'
  93         fails = fails + 1
  94     endif
  95     if (check_scalar .ne. scalar) then
  96         print *, 2 + off, check_scalar, '(', scalar, ')'
  97         fails = fails + 1
  98     endif
  99     if (any (check_array(1:size (array, 1)) .ne. array)) then
 100         print *, 3 + off, check_array(1:size (array, 1)) , '(', array, ')'
 101         fails = fails + 1
 102     endif
 103     if (present (rind)) then
 104       if (check_real .ne. rind) then
 105         print *, 4 + off, check_real,'(', rind, ')'
 106         fails = fails + 1
 107       endif
 108     end if
 109     if (present (rarray)) then
 110       if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
 111         print *, 5 + off, check_rarray(1:size (rarray, 1)), '(', rarray, ')'
 112         fails = fails + 1
 113       endif
 114     end if
 115     final_count = 0
 116   end subroutine test
 117 end module testmode
 118
 119 program test_final
 120   use testmode
 121   implicit none
 122
 123   type(simple), allocatable :: MyType, MyType2
 124   type(simple), allocatable :: MyTypeArray(:)
 125   type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
 126   class(simple), allocatable :: MyClass
 127   class(simple), allocatable :: MyClassArray(:)
 128
 129 ! ************************
 130 ! Derived type assignments
 131 ! ************************
 132
 133 ! The original PR - no finalization of 'var' before (re)allocation
 134 ! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
 135   MyType = ThyType
 136   call test(0, 0, [0,0], 0)
 137
 138   if (.not. allocated(MyType)) allocate(MyType)
 139   allocate(MyType2)
 140   MyType%ind = 1
 141   MyType2%ind = 2
 142
 143 ! This should result in a final call with self = simple(1) (para 1 of F2018 7.5.6.3.).
 144   MyType = MyType2
 145   call test(1, 1, [0,0], 10)
 146
 147   allocate(MyTypeArray(2))
 148   MyTypeArray%ind = [42, 43]
 149 ! This should result in a final call with self = [simple(42),simple(43)],
 150 ! followed by the finalization of the array constructor = self = [simple(21),simple(22)].
 151   MyTypeArray = [ThyType, ThyType2] ! { dg-warning "has been finalized" }
 152   call test(2, 0, [21,22], 20)
 153
 154 ! This should result in a final call 'var' = initialization = simple(22),
 155 ! followed by one with for the structure constructor.
 156   ThyType2 = simple(99) ! { dg-warning "has been finalized" }
 157   call test(2, 99, [0,0], 30)
 158
 159 ! This should result in a final call for 'var' with self = simple(21).
 160   ThyType = ThyType2
 161   call test(1, 21, [0,0], 40)
 162
 163 ! This should result in two final calls; the last is for Mytype2 = simple(2).
 164   deallocate (MyType, MyType2)
 165   call test(2, 2, [0,0], 50)
 166
 167 ! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
 168   deallocate (MyTypeArray)
 169   call test(1, 0, [21,22], 60)
 170
 171 ! The lhs is finalized before assignment.
 172 ! The function result is finalized after the assignment.
 173   allocate (MyType, source = simple (11))
 174   MyType = constructor1 (99)
 175   call test(2, 99, [0,0], 70)
 176   deallocate (MyType)
 177 ! *****************
 178 ! Class assignments
 179 ! *****************
 180
 181   final_count = 0
 182
 183 ! This should result in a final call for MyClass, which is simple(3) and then
 184 ! the structure constructor with value simple(4)).
 185   allocate (MyClass, source = simple (3))
 186   MyClass = simple (4) ! { dg-warning "has been finalized" }
 187   call test(2, 4, [0,0], 100)
 188
 189 ! This should result in a final call with the assigned value of simple(4).
 190   deallocate (MyClass)
 191   call test(1, 4, [0,0], 110)
 192
 193
 194   allocate (MyClassArray, source = [simple (5), simple (6)])
 195 ! Make sure that there is no final call since MyClassArray is not allocated.
 196   call test(0, 4, [0,0], 120)
 197
 198   MyClassArray = [simple (7), simple (8)] ! { dg-warning "has been finalized" }
 199 ! The first final call should finalize MyClassArray and the second should return
 200 ! the value of the array constructor.
 201   call test(2, 0, [7,8], 130)
 202
 203 ! This should result in a final call with the assigned value.
 204   deallocate (MyClassArray)
 205   call test(1, 0, [7,8], 140)
 206
 207 ! This should produce no final calls since MyClassArray was deallocated.
 208   allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
 209
 210 ! This should produce calls to destructor4 then destructor2.
 211   deallocate (MyClassArray)
 212
 213 ! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
 214 ! finalizable, the parent component is finalized.
 215   call test(2, 0, [1, 3], 150, rarray = [2.0, 4.0])
 216
 217 ! This produces 2 final calls in turn for 'src' as it goes out of scope, for
 218 ! MyClassArray before it is assigned to and the result of 'constructor2' after
 219 ! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
 220   MyClassArray = constructor2 ([10,20], [10.0,20.0])
 221   call test(6, 0, [10,20], 160, rarray = [10.0,20.0])
 222
 223 ! This produces two final calls with the contents of 'MyClassArray. and its
 224 ! parent component.
 225   deallocate (MyClassArray)
 226   call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])
 227
 228 ! Clean up for valgrind testing
 229   if (allocated (MyType)) deallocate (MyType)
 230   if (allocated (MyType2)) deallocate (MyType2)
 231   if (allocated (MyTypeArray)) deallocate (MyTypeArray)
 232   if (allocated (MyClass)) deallocate (MyClass)
 233   if (allocated (MyClassArray)) deallocate (MyClassArray)
 234
 235 ! Error messages printed out by 'test'.
 236   if (fails .ne. 0) then
 237    Print *, fails, " Errors"
 238    error stop
 239   endif
 240 end program test_final