gcc/testsuite/gfortran.dg/finalize_46.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for pr88735.
   4 !
   5 ! Contributed by Martin Stein  <mscfd@gmx.net>
   6 !
   7 module mod
   8   implicit none
   9   type, public :: t
  10      integer, pointer :: i => NULL ()
  11      character :: myname = 'z'
  12      character :: alloc = 'n'
  13   contains
  14      procedure, public :: set
  15      generic, public :: assignment(=) => set
  16      final :: finalise
  17   end type t
  18   integer, public :: assoc_in_final = 0
  19   integer, public :: calls_to_final = 0
  20   character, public :: myname1, myname2
  21
  22 contains
  23
  24   subroutine set(self, x)
  25      class(t), intent(out) :: self
  26      class(t), intent(in)  :: x
  27      if (associated(self%i)) then
  28         stop 1                               ! Default init for INTENT(OUT)
  29      endif
  30      if (associated(x%i)) then
  31         myname2 = self%myname
  32         self%i => x%i
  33         self%i = self%i + 1
  34      end if
  35 end subroutine set
  36
  37   subroutine finalise(self)
  38      type(t), intent(inout) :: self
  39      calls_to_final = calls_to_final + 1
  40      myname1 = self%myname
  41      if (associated(self%i)) then
  42         assoc_in_final = assoc_in_final + 1
  43         if (self%alloc .eq. 'y') deallocate (self%i)
  44      end if
  45   end subroutine finalise
  46
  47 end module mod
  48
  49 program finalise_assign
  50   use mod
  51   implicit none
  52   type :: s
  53      integer :: i = 0
  54      type(t) :: x
  55   end type s
  56   type(s) :: a, b
  57   type(t) :: c
  58   a%x%myname = 'a'
  59   b%x%myname = 'b'
  60   c%myname = 'c'
  61   allocate (a%x%i)
  62   a%x%i = 123
  63   a%x%alloc = 'y'
  64
  65   b = a
  66   if (assoc_in_final /= 0) stop 2  ! b%x%i not associated before finalization
  67   if (calls_to_final /= 2) stop 3  ! One finalization call
  68   if (myname1 .ne. 'b') stop 4     ! Finalization before intent out become undefined
  69   if (myname2 .ne. 'z') stop 5     ! Intent out now default initialized
  70   if (.not.associated (b%x%i, a%x%i)) stop 6
  71
  72   allocate (c%i, source = 789)
  73   c%alloc = 'y'
  74   c = a%x
  75   if (assoc_in_final /= 1) stop 6  ! c%i is allocated prior to the assignment
  76   if (calls_to_final /= 3) stop 7  ! One finalization call for the assignment
  77   if (myname1 .ne. 'c') stop 8     ! Finalization before intent out become undefined
  78   if (myname2 .ne. 'z') stop 9     ! Intent out now default initialized
  79
  80   b = a
  81   if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
  82   if (calls_to_final /= 5) stop 11 ! One finalization call for the assignment
  83   if (myname1 .ne. 'z') stop 12    ! b%x%myname was default initialized in earlier assignment
  84   if (myname2 .ne. 'z') stop 13    ! Intent out now default initialized
  85   if (b%x%i .ne. 126) stop 14      ! Three assignments with self%x%i pointing to same target
  86   deallocate (a%x%i)
  87   if (.not.associated (b%x%i, c%i)) then
  88     stop 15                        ! ditto
  89     b%x%i =>NULL ()                ! Although not needed here, clean up
  90     c%i => NULL ()
  91   endif
  92 end program finalise_assign