gcc/testsuite/gfortran.dg/finalize_50.f90

   1 ! { dg-do run }
   2 !
   3 ! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Most of PR106576:
   4 ! The finalization of function results within specification expressions is tested
   5 ! in finalize_49.f90.
   6 !
   7 ! Contributed by Damian Rouson  <damian@archaeologic.codes>
   8 !
   9 module test_result_m
  10   !! Define tests for each scenario in which the Fortran 2018
  11   !! standard mandates type finalization.
  12   implicit none
  13
  14   private
  15   public :: test_result_t, get_test_results
  16
  17   type test_result_t
  18     character(len=132) description
  19     logical outcome
  20   end type
  21
  22   type object_t
  23     integer dummy
  24   contains
  25     final :: count_finalizations
  26   end type
  27
  28   type wrapper_t
  29     private
  30     type(object_t), allocatable :: object
  31   end type
  32
  33   integer :: finalizations = 0
  34   integer, parameter :: avoid_unused_variable_warning = 1
  35
  36 contains
  37
  38   function get_test_results() result(test_results)
  39     type(test_result_t), allocatable :: test_results(:)
  40
  41     test_results = [ &
  42        test_result_t("finalizes a non-allocatable object on the LHS of an intrinsic assignment", lhs_object()) &
  43       ,test_result_t("finalizes an allocated allocatable LHS of an intrinsic assignment", allocated_allocatable_lhs()) &
  44       ,test_result_t("finalizes a target when the associated pointer is deallocated", target_deallocation()) &
  45       ,test_result_t("finalizes an object upon explicit deallocation", finalize_on_deallocate()) &
  46       ,test_result_t("finalizes a non-pointer non-allocatable object at the END statement", finalize_on_end()) &
  47       ,test_result_t("finalizes a non-pointer non-allocatable object at the end of a block construct", block_end()) &
  48       ,test_result_t("finalizes a function reference on the RHS of an intrinsic assignment", rhs_function_reference()) &
  49       ,test_result_t("finalizes an intent(out) derived type dummy argument", intent_out()) &
  50       ,test_result_t("finalizes an allocatable component object", allocatable_component()) &
  51     ]
  52   end function
  53
  54   function construct_object() result(object)
  55     !! Constructor for object_t
  56     type(object_t) object
  57     object % dummy = avoid_unused_variable_warning
  58   end function
  59
  60   subroutine count_finalizations(self)
  61     !! Destructor for object_t
  62     type(object_t), intent(inout) :: self
  63     finalizations = finalizations + 1
  64     self % dummy = avoid_unused_variable_warning
  65   end subroutine
  66
  67   function lhs_object() result(outcome)
  68     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
  69     !! "not an unallocated allocatable variable"
  70     type(object_t) lhs, rhs
  71     logical outcome
  72     integer initial_tally
  73
  74     rhs%dummy = avoid_unused_variable_warning
  75     initial_tally = finalizations
  76     lhs = rhs ! finalizes lhs
  77     associate(finalization_tally => finalizations - initial_tally)
  78       outcome = finalization_tally==1
  79     end associate
  80   end function
  81
  82   function allocated_allocatable_lhs() result(outcome)
  83     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
  84     !! "allocated allocatable variable"
  85     type(object_t), allocatable :: lhs
  86     type(object_t) rhs
  87     logical outcome
  88     integer initial_tally
  89
  90     rhs%dummy = avoid_unused_variable_warning
  91     initial_tally = finalizations
  92     allocate(lhs)
  93     lhs = rhs ! finalizes lhs
  94     associate(finalization_tally => finalizations - initial_tally)
  95       outcome = finalization_tally==1
  96     end associate
  97   end function
  98
  99   function target_deallocation() result(outcome)
 100     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2 behavior:
 101     !! "pointer is deallocated"
 102     type(object_t), pointer :: object_ptr => null()
 103     logical outcome
 104     integer initial_tally
 105
 106     allocate(object_ptr, source=object_t(dummy=0))
 107     initial_tally = finalizations
 108     deallocate(object_ptr) ! finalizes object
 109     associate(finalization_tally => finalizations - initial_tally)
 110       outcome = finalization_tally==1
 111     end associate
 112   end function
 113
 114   function allocatable_component() result(outcome)
 115     !! Test conformance with Fortran 2018 clause 7.5.6.3, para. 2 ("allocatable entity is deallocated")
 116     !! + 9.7.3.2, para. 6 ("INTENT(OUT) allocatable dummy argument is deallocated")
 117     type(wrapper_t), allocatable :: wrapper
 118     logical outcome
 119     integer initial_tally
 120
 121     initial_tally = finalizations
 122
 123     allocate(wrapper)
 124     allocate(wrapper%object)
 125     call finalize_intent_out_component(wrapper)
 126     associate(finalization_tally => finalizations - initial_tally)
 127       outcome = finalization_tally==1
 128     end associate
 129
 130   contains
 131
 132     subroutine finalize_intent_out_component(output)
 133       type(wrapper_t), intent(out) :: output ! finalizes object component
 134       allocate(output%object)
 135       output%object%dummy = avoid_unused_variable_warning
 136     end subroutine
 137
 138   end function
 139
 140   function finalize_on_deallocate() result(outcome)
 141     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2:
 142     !! "allocatable entity is deallocated"
 143     type(object_t), allocatable :: object
 144     logical outcome
 145     integer initial_tally
 146
 147     initial_tally = finalizations
 148     allocate(object)
 149     object%dummy = 1
 150     deallocate(object)          ! finalizes object
 151     associate(final_tally => finalizations - initial_tally)
 152       outcome = final_tally==1
 153     end associate
 154   end function
 155
 156   function finalize_on_end() result(outcome)
 157     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 3:
 158     !! "before return or END statement"
 159     logical outcome
 160     integer initial_tally
 161
 162     initial_tally = finalizations
 163     call finalize_on_end_subroutine() ! Finalizes local_obj
 164     associate(final_tally => finalizations - initial_tally)
 165       outcome = final_tally==1
 166     end associate
 167
 168   contains
 169
 170     subroutine finalize_on_end_subroutine()
 171       type(object_t) local_obj
 172       local_obj % dummy = avoid_unused_variable_warning
 173     end subroutine
 174
 175   end function
 176
 177   function block_end() result(outcome)
 178     !! Test conformance with Fortran 2018 clause  7.5.6.3, paragraph 4:
 179     !! "termination of the BLOCK construct"
 180     logical outcome
 181     integer initial_tally
 182
 183     initial_tally = finalizations
 184     block
 185       type(object_t) object
 186       object % dummy = avoid_unused_variable_warning
 187     end block ! Finalizes object
 188     associate(finalization_tally => finalizations - initial_tally)
 189       outcome = finalization_tally==1
 190     end associate
 191   end function
 192
 193   function rhs_function_reference() result(outcome)
 194     !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 5 behavior:
 195     !! "nonpointer function result"
 196     type(object_t), allocatable :: object
 197     logical outcome
 198     integer initial_tally
 199
 200     initial_tally = finalizations
 201     object = construct_object() ! finalizes object_t result
 202     associate(finalization_tally => finalizations - initial_tally)
 203       outcome = finalization_tally==1
 204     end associate
 205   end function
 206
 207   function intent_out() result(outcome)
 208     !! Test conformance with Fortran 2018 standard clause 7.5.6.3, paragraph 7:
 209     !! "nonpointer, nonallocatable, INTENT (OUT) dummy argument"
 210     logical outcome
 211     type(object_t) object
 212     integer initial_tally
 213
 214     initial_tally = finalizations
 215     call finalize_intent_out_arg(object)
 216     associate(finalization_tally => finalizations - initial_tally)
 217       outcome = finalization_tally==1
 218     end associate
 219   contains
 220     subroutine finalize_intent_out_arg(output)
 221       type(object_t), intent(out) :: output ! finalizes output
 222       output%dummy = avoid_unused_variable_warning
 223     end subroutine
 224   end function
 225
 226 end module test_result_m
 227
 228 program main
 229   !! Test each scenario in which the Fortran 2018 standard
 230   !! requires type finalization.
 231   use test_result_m, only : test_result_t, get_test_results
 232   implicit none
 233   type(test_result_t), allocatable :: test_results(:)
 234   integer i
 235
 236   test_results = get_test_results()
 237
 238   do i=1,size(test_results)
 239     print *, report(test_results(i)%outcome), test_results(i)%description
 240   end do
 241
 242   if (any(.not.test_results%outcome)) stop "Failing tests"
 243
 244   if (allocated (test_results)) deallocate (test_results)
 245
 246 contains
 247
 248   pure function report(outcome)
 249     logical, intent(in) :: outcome
 250     character(len=:), allocatable ::  report
 251     report = merge("Pass: ", "Fail: ", outcome)
 252   end function
 253
 254 end program