gcc/testsuite/gfortran.dg/finalize_33.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Tests the fix for PR87359 in which the finalization of
   5 ! 'source=process%component%extract_mci_template()' in the allocation
   6 ! of 'process%mci' caused invalid reads and freeing of already freed
   7 ! memory. This test is a greatly reduced version of the original code.
   8 !
   9 ! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
  10 !
  11 module mci_base
  12   implicit none
  13   private
  14   public :: mci_t
  15   public :: mci_midpoint_t
  16   public :: cnt
  17   integer :: cnt = 0
  18   type, abstract :: mci_t
  19      integer, dimension(:), allocatable :: chain
  20   end type mci_t
  21   type, extends (mci_t) :: mci_midpoint_t
  22   contains
  23     final :: mci_midpoint_final
  24   end type mci_midpoint_t
  25 contains
  26   IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg)
  27     TYPE(mci_midpoint_t), INTENT(INOUT) :: arg
  28     cnt = cnt + 1
  29   END SUBROUTINE mci_midpoint_final
  30 end module mci_base
  31
  32 !!!!!
  33
  34 module process_config
  35   use mci_base
  36   implicit none
  37   private
  38   public :: process_component_t
  39   type :: process_component_t
  40      class(mci_t), allocatable :: mci_template
  41    contains
  42      procedure :: init => process_component_init
  43      procedure :: extract_mci_template => process_component_extract_mci_template
  44   end type process_component_t
  45
  46 contains
  47
  48   subroutine process_component_init (component, mci_template)
  49     class(process_component_t), intent(out) :: component
  50     class(mci_t), intent(in), allocatable :: mci_template
  51     if (allocated (mci_template)) &
  52          allocate (component%mci_template, source = mci_template)
  53   end subroutine process_component_init
  54
  55   function process_component_extract_mci_template (component) &
  56          result (mci_template)
  57     class(mci_t), allocatable :: mci_template
  58     class(process_component_t), intent(in) :: component
  59     if (allocated (component%mci_template)) &
  60        allocate (mci_template, source = component%mci_template)
  61   end function process_component_extract_mci_template
  62 end module process_config
  63
  64 !!!!!
  65
  66 module process
  67   use mci_base
  68   use process_config
  69   implicit none
  70   private
  71   public :: process_t
  72   type :: process_t
  73      private
  74      type(process_component_t) :: component
  75      class(mci_t), allocatable :: mci
  76    contains
  77      procedure :: init_component => process_init_component
  78      procedure :: setup_mci => process_setup_mci
  79   end type process_t
  80 contains
  81   subroutine process_init_component &
  82        (process, mci_template)
  83     class(process_t), intent(inout), target :: process
  84     class(mci_t), intent(in), allocatable :: mci_template
  85     call process%component%init (mci_template)
  86   end subroutine process_init_component
  87
  88   subroutine process_setup_mci (process)
  89     class(process_t), intent(inout) :: process
  90     allocate (process%mci, source=process%component%extract_mci_template ())
  91   end subroutine process_setup_mci
  92
  93 end module process
  94
  95 !!!!!
  96
  97 program main_ut
  98   use mci_base
  99   use process, only: process_t
 100   implicit none
 101   call event_transforms_1 ()
 102   if (cnt .ne. 4) stop 2
 103 contains
 104
 105   subroutine event_transforms_1 ()
 106     class(mci_t), allocatable :: mci_template
 107     type(process_t), allocatable, target :: process
 108     allocate (process)
 109     allocate (mci_midpoint_t :: mci_template)
 110     call process%init_component (mci_template)
 111     call process%setup_mci ()                  ! generates 1 final call from call to extract_mci_template
 112     if (cnt .ne. 1) stop 1
 113   end subroutine event_transforms_1            ! generates 3 final calls to mci_midpoint_final:
 114                                                ! (i) process%component%mci_template
 115                                                ! (ii) process%mci
 116                                                ! (iii) mci_template
 117 end program main_ut
 118 ! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } }
 119 ! { dg-final { scan-tree-dump-times "__builtin_free" 20 "original" } }