gcc/testsuite/gfortran.dg/finalize_55.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR113885, where not only was there a gimplifier ICE
   3 ! for a derived type 't' with no components but this version gave wrong
   4 ! results.
   5 ! Contributed by David Binderman  <dcb314@hotmail.com>
   6 !
   7 module types
   8   type t
   9      integer :: i
  10    contains
  11      final :: finalize
  12   end type t
  13   integer :: ctr = 0
  14 contains
  15   impure elemental subroutine finalize(x)
  16     type(t), intent(inout) :: x
  17     ctr = ctr + 1
  18   end subroutine finalize
  19 end module types
  20
  21 impure elemental function elem(x)
  22   use types
  23   type(t), intent(in) :: x
  24   type(t) :: elem
  25   elem%i = x%i + 1
  26 end function elem
  27
  28 impure elemental function elem2(x, y)
  29   use types
  30   type(t), intent(in) :: x, y
  31   type(t) :: elem2
  32   elem2%i = x%i + y%i
  33 end function elem2
  34
  35 subroutine test1(x)
  36   use types
  37   interface
  38      impure elemental function elem(x)
  39        use types
  40        type(t), intent(in) :: x
  41        type(t) :: elem
  42      end function elem
  43   end interface
  44   type(t) :: x(:)
  45   type(t), allocatable :: y(:)
  46   y = x
  47   x = elem(y)
  48 end subroutine test1
  49
  50 subroutine test2(x)
  51   use types
  52   interface
  53      impure elemental function elem(x)
  54        use types
  55        type(t), intent(in) :: x
  56        type(t) :: elem
  57      end function elem
  58      impure elemental function elem2(x, y)
  59        use types
  60        type(t), intent(in) :: x, y
  61        type(t) :: elem2
  62      end function elem2
  63   end interface
  64   type(t) :: x(:)
  65   type(t), allocatable :: y(:)
  66   y = x
  67   x = elem2(elem(y), elem(y))
  68 end subroutine test2
  69
  70 program test113885
  71   use types
  72   interface
  73     subroutine test1(x)
  74       use types
  75       type(t) :: x(:)
  76     end subroutine
  77     subroutine test2(x)
  78       use types
  79       type(t) :: x(:)
  80     end subroutine
  81   end interface
  82   type(t) :: x(2) = [t(1),t(2)]
  83   call test1 (x)
  84   if (any (x%i .ne. [2,3])) stop 1
  85   if (ctr .ne. 6) stop 2
  86   call test2 (x)
  87   if (any (x%i .ne. [6,8])) stop 3
  88   if (ctr .ne. 16) stop 4
  89 end