gcc/testsuite/gfortran.dg/finalize_38.f90

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