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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
! { dg-do run }
!
! Test that PR69298 is fixed. Used to segfault on finalization in
! subroutine 'in_type'.
!
! Contributed by Neil Carlson <neil.n.carlson@gmail.com>
!
module stuff_mod
implicit none
private
public :: stuff_type, final_calls
type stuff_type
private
integer :: junk
contains
procedure get_junk
procedure stuff_copy_initialiser
generic :: assignment(=) => stuff_copy_initialiser
final :: stuff_scalar_finaliser, &
stuff_1d_finaliser
end type stuff_type
integer :: final_calls = 0
interface stuff_type
procedure stuff_initialiser
end interface stuff_type
contains
function stuff_initialiser( junk ) result(new_stuff)
implicit none
type(stuff_type) :: new_stuff
integer :: junk
new_stuff%junk = junk
end function stuff_initialiser
subroutine stuff_copy_initialiser( destination, source )
implicit none
class(stuff_type), intent(out) :: destination
class(stuff_type), intent(in) :: source
destination%junk = source%junk
end subroutine stuff_copy_initialiser
subroutine stuff_scalar_finaliser( this )
implicit none
type(stuff_type), intent(inout) :: this
final_calls = final_calls + 1
end subroutine stuff_scalar_finaliser
subroutine stuff_1d_finaliser( this )
implicit none
type(stuff_type), intent(inout) :: this(:)
integer :: i
final_calls = final_calls + 100
end subroutine stuff_1d_finaliser
function get_junk( this ) result(junk)
implicit none
class(stuff_type), intent(in) :: this
integer :: junk
junk = this%junk
end function get_junk
end module stuff_mod
module test_mod
use stuff_mod, only : stuff_type, final_calls
implicit none
private
public :: test_type
type test_type
private
type(stuff_type) :: thing
type(stuff_type) :: things(3)
contains
procedure get_value
end type test_type
interface test_type
procedure test_type_initialiser
end interface test_type
contains
function test_type_initialiser() result(new_test)
implicit none
type(test_type) :: new_test
integer :: i ! At entry: 1 array and 9 scalars
new_test%thing = stuff_type( 4 ) ! Gives 2 scalar calls
do i = 1, 3
new_test%things(i) = stuff_type( i ) ! Gives 6 scalar calls
end do
end function test_type_initialiser
function get_value( this ) result(value)
implicit none
class(test_type) :: this
integer :: value
integer :: i
value = this%thing%get_junk()
do i = 1, 3
value = value + this%things(i)%get_junk()
end do
end function get_value
end module test_mod
program test
use stuff_mod, only : stuff_type, final_calls
use test_mod, only : test_type
implicit none
call here()
! One array call and 1 scalar call after leaving scope => 1 + 9 total; NAGFOR and IFORT agree
if (final_calls .ne. 109) stop 1
call in_type()
! 21 calls to scalar finalizer and 4 to the vector version; IFORT agrees
! NAGFOR also produces 21 scalar calls but 5 vector calls.
if (final_calls .ne. 421) print *, final_calls
contains
subroutine here()
implicit none
type(stuff_type) :: thing
type(stuff_type) :: bits(3)
integer :: i
integer :: tally
thing = stuff_type(4) ! Two scalar final calls; INTENT(OUT) and initialiser
do i = 1, 3
bits(i) = stuff_type(i) ! ditto times 3
end do
tally = thing%get_junk()
do i = 1, 3
tally = tally + bits(i)%get_junk()
end do
if (tally .ne. 10) stop 3 ! 8 scalar final calls by here
end subroutine here
subroutine in_type()
implicit none
type(test_type) :: thing
thing = test_type() ! 8 scalar in test_type + 1 vector and 1 scalar to finalize function result and
! 1 vectors and 2 scalars from the expansion of the defined assignment.
if (thing%get_value() .ne. 10) stop 4
end subroutine in_type
end program test
|
