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