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