gcc/testsuite/gfortran.dg/finalize_52.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR104272 in which allocate caused an unwanted finalization
   4 !
   5 ! Contributed by Kai Germaschewski  <kai.germaschewski@gmail.com>
   6 !
   7 module solver_m
   8     implicit none
   9
  10     type, abstract, public :: solver_base_t
  11     end type solver_base_t
  12
  13     type, public, extends(solver_base_t) :: solver_gpu_t
  14        complex, dimension(:), allocatable :: x
  15     contains
  16        final :: solver_gpu_final
  17     end type solver_gpu_t
  18
  19     type, public, extends(solver_gpu_t) :: solver_sparse_gpu_t
  20     contains
  21        final :: solver_sparse_gpu_final
  22     end type solver_sparse_gpu_t
  23
  24     integer :: final_counts = 0
  25
  26  contains
  27
  28     impure elemental subroutine solver_gpu_final(this)
  29        type(solver_gpu_t), intent(INOUT) :: this
  30        final_counts = final_counts + 1
  31     end subroutine solver_gpu_final
  32
  33     impure elemental subroutine solver_sparse_gpu_final(this)
  34        type(solver_sparse_gpu_t), intent(INOUT) :: this
  35        final_counts = final_counts + 10
  36     end subroutine solver_sparse_gpu_final
  37
  38  end module solver_m
  39
  40  subroutine test
  41     use solver_m
  42     implicit none
  43
  44     class(solver_base_t), dimension(:), allocatable :: solver
  45
  46     allocate(solver_sparse_gpu_t :: solver(2))
  47
  48     if (final_counts .ne. 0) stop 1
  49  end subroutine
  50
  51 program main
  52     use solver_m
  53     implicit none
  54
  55     call test
  56     if (final_counts .ne. 22) stop 2 ! Scalar finalizers for rank 1/size 2
  57 end program