gcc/testsuite/gfortran.dg/finalize_51.f90

   1 ! { dg-do run }
   2 !
   3 ! Test assumed rank finalizers
   4 !
   5 module finalizable_m
   6 ! F2018: 7.5.6.2 para 1: "Otherwise, if there is an elemental final
   7 ! subroutine whose dummy argument has the same kind type parameters
   8 ! as the entity being finalized, or a final subroutine whose dummy
   9 ! argument is assumed-rank with the same kind type parameters as the
  10 ! entity being finalized, it is called with the entity as an actual
  11 ! argument."
  12   implicit none
  13
  14   type finalizable_t
  15     integer :: component_
  16   contains
  17     final :: finalize
  18   end Type
  19
  20   interface finalizable_type
  21     module procedure construct0, construct1
  22   end interface
  23
  24   integer :: final_ctr = 0
  25
  26 contains
  27
  28   pure function construct0(component) result(finalizable)
  29     integer, intent(in) :: component
  30     type(finalizable_t) finalizable
  31     finalizable%component_ = component
  32   end function
  33
  34   impure function construct1(component) result(finalizable)
  35     integer, intent(in), dimension(:) :: component
  36     type(finalizable_t), dimension(:), allocatable :: finalizable
  37     integer :: sz
  38     sz = size(component)
  39     allocate (finalizable (sz))
  40     finalizable%component_ = component
  41   end function
  42
  43   subroutine finalize(self)
  44     type(finalizable_t), intent(inout), dimension (..) :: self
  45     select rank (self)
  46     rank (0)
  47         print *, "rank 0 value = ", self%component_
  48     rank (1)
  49         print *, "rank 1 value = ", self%component_
  50     rank default
  51         print *, "rank default"
  52     end select
  53     final_ctr = final_ctr + 1
  54   end subroutine
  55
  56 end module
  57
  58 program specification_expression_finalization
  59   use finalizable_m
  60   implicit none
  61
  62   type(finalizable_t) :: a = finalizable_t (1)
  63   type(finalizable_t) :: b(2) = [finalizable_t (2), finalizable_t (3)]
  64
  65   a = finalizable_type (42)
  66   if (final_ctr .ne. 2) stop 1
  67   b = finalizable_type ([42, 43])
  68   print *, b%component_
  69
  70 end program