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!
11module 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
25contains
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
30end module mci_base
31
32!!!!!
33
34module 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
46contains
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
62end module process_config
63
64!!!!!
65
66module 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
80contains
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
93end module process
94
95!!!!!
96
97program 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
103contains
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
117end 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" } }
120