gcc/testsuite/gfortran.dg/finalize_41.f90

   1 ! { dg-do run }
   2 !
   3 ! Test that PR69298 is fixed. Used to segfault on finalization in
   4 ! subroutine 'in_type'.
   5 !
   6 ! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
   7 !
   8 module stuff_mod
   9   implicit none
  10   private
  11   public :: stuff_type, final_calls
  12   type stuff_type
  13     private
  14     integer :: junk
  15   contains
  16     procedure get_junk
  17     procedure stuff_copy_initialiser
  18     generic :: assignment(=) => stuff_copy_initialiser
  19     final :: stuff_scalar_finaliser, &
  20              stuff_1d_finaliser
  21   end type stuff_type
  22   integer :: final_calls = 0
  23   interface stuff_type
  24     procedure stuff_initialiser
  25   end interface stuff_type
  26 contains
  27
  28   function stuff_initialiser( junk ) result(new_stuff)
  29     implicit none
  30     type(stuff_type) :: new_stuff
  31     integer :: junk
  32     new_stuff%junk = junk
  33   end function stuff_initialiser
  34
  35   subroutine stuff_copy_initialiser( destination, source )
  36     implicit none
  37     class(stuff_type), intent(out) :: destination
  38     class(stuff_type), intent(in)  :: source
  39     destination%junk = source%junk
  40   end subroutine stuff_copy_initialiser
  41
  42   subroutine stuff_scalar_finaliser( this )
  43     implicit none
  44     type(stuff_type), intent(inout) :: this
  45     final_calls = final_calls + 1
  46   end subroutine stuff_scalar_finaliser
  47
  48   subroutine stuff_1d_finaliser( this )
  49     implicit none
  50     type(stuff_type), intent(inout) :: this(:)
  51     integer :: i
  52     final_calls = final_calls + 100
  53   end subroutine stuff_1d_finaliser
  54
  55   function get_junk( this ) result(junk)
  56     implicit none
  57     class(stuff_type), intent(in) :: this
  58     integer :: junk
  59     junk = this%junk
  60   end function get_junk
  61 end module stuff_mod
  62
  63 module test_mod
  64   use stuff_mod, only : stuff_type, final_calls
  65   implicit none
  66   private
  67   public :: test_type
  68   type test_type
  69     private
  70     type(stuff_type) :: thing
  71     type(stuff_type) :: things(3)
  72   contains
  73     procedure get_value
  74   end type test_type
  75   interface test_type
  76     procedure test_type_initialiser
  77   end interface test_type
  78 contains
  79
  80   function test_type_initialiser() result(new_test)
  81     implicit none
  82     type(test_type) :: new_test
  83     integer :: i ! At entry: 1 array and 9 scalars
  84     new_test%thing = stuff_type( 4 ) ! Gives 2 scalar calls
  85     do i = 1, 3
  86       new_test%things(i) = stuff_type( i )  ! Gives 6 scalar calls
  87     end do
  88   end function test_type_initialiser
  89
  90   function get_value( this ) result(value)
  91     implicit none
  92     class(test_type) :: this
  93     integer :: value
  94     integer :: i
  95     value = this%thing%get_junk()
  96     do i = 1, 3
  97       value = value + this%things(i)%get_junk()
  98     end do
  99   end function get_value
 100 end module test_mod
 101
 102 program test
 103   use stuff_mod, only : stuff_type, final_calls
 104   use test_mod,  only : test_type
 105   implicit none
 106   call here()
 107 ! One array call and 1 scalar call after leaving scope => 1 + 9 total; NAGFOR and IFORT agree
 108   if (final_calls .ne. 109) stop 1
 109   call in_type()
 110 ! 21 calls to scalar finalizer and 4 to the vector version; IFORT agrees
 111 ! NAGFOR also produces 21 scalar calls but 5 vector calls.
 112   if (final_calls .ne. 421) print *, final_calls
 113 contains
 114
 115   subroutine here()
 116     implicit none
 117     type(stuff_type) :: thing
 118     type(stuff_type) :: bits(3)
 119     integer :: i
 120     integer :: tally
 121     thing = stuff_type(4) ! Two scalar final calls; INTENT(OUT) and initialiser
 122     do i = 1, 3
 123       bits(i) = stuff_type(i) ! ditto times 3
 124     end do
 125     tally = thing%get_junk()
 126     do i = 1, 3
 127       tally = tally + bits(i)%get_junk()
 128     end do
 129     if (tally .ne. 10) stop 3 ! 8 scalar final calls by here
 130   end subroutine here
 131
 132   subroutine in_type()
 133     implicit none
 134     type(test_type) :: thing
 135     thing = test_type() ! 8 scalar in test_type + 1 vector and 1 scalar to finalize function result and
 136                         ! 1 vectors and 2 scalars from the expansion of the defined assignment.
 137     if (thing%get_value() .ne. 10) stop 4
 138   end subroutine in_type
 139 end program test