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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
! { dg-do run }
! Tests the fic for PR44582, where gfortran was found to
! produce an incorrect result when the result of a function
! was aliased by a host or use associated variable, to which
! the function is assigned. In these cases a temporary is
! required in the function assignments. The check has to be
! rather restrictive. Whilst the cases marked below might
! not need temporaries, the TODOs are going to be tough.
!
! Reported by Yin Ma <yin@absoft.com> and
! elaborated by Tobias Burnus <burnus@gcc.gnu.org>
!
module foo
INTEGER, PARAMETER :: ONE = 1
INTEGER, PARAMETER :: TEN = 10
INTEGER, PARAMETER :: FIVE = TEN/2
INTEGER, PARAMETER :: TWO = 2
integer :: foo_a(ONE)
integer :: check(ONE) = TEN
LOGICAL :: abort_flag = .false.
contains
function foo_f()
integer :: foo_f(ONE)
foo_f = -FIVE
foo_f = foo_a - foo_f
end function foo_f
subroutine bar
foo_a = FIVE
! This aliases 'foo_a' by host association.
foo_a = foo_f ()
if (any (foo_a .ne. check)) call myabort (0)
end subroutine bar
subroutine myabort(fl)
integer :: fl
print *, fl
abort_flag = .true.
end subroutine myabort
end module foo
function h_ext()
use foo
integer :: h_ext(ONE)
h_ext = -FIVE
h_ext = FIVE - h_ext
end function h_ext
function i_ext() result (h)
use foo
integer :: h(ONE)
h = -FIVE
h = FIVE - h
end function i_ext
subroutine tobias
use foo
integer :: a(ONE)
a = FIVE
call sub1(a)
if (any (a .ne. check)) call myabort (1)
contains
subroutine sub1(x)
integer :: x(ONE)
! 'x' is aliased by host association in 'f'.
x = f()
end subroutine sub1
function f()
integer :: f(ONE)
f = ONE
f = a + FIVE
end function f
end subroutine tobias
program test
use foo
implicit none
common /foo_bar/ c
integer :: a(ONE), b(ONE), c(ONE), d(ONE)
interface
function h_ext()
use foo
integer :: h_ext(ONE)
end function h_ext
end interface
interface
function i_ext() result (h)
use foo
integer :: h(ONE)
end function i_ext
end interface
a = FIVE
! This aliases 'a' by host association
a = f()
if (any (a .ne. check)) call myabort (2)
a = FIVE
if (any (f() .ne. check)) call myabort (3)
call bar
foo_a = FIVE
! This aliases 'foo_a' by host association.
foo_a = g ()
if (any (foo_a .ne. check)) call myabort (4)
a = FIVE
a = h() ! TODO: Needs no temporary
if (any (a .ne. check)) call myabort (5)
a = FIVE
a = i() ! TODO: Needs no temporary
if (any (a .ne. check)) call myabort (6)
a = FIVE
a = h_ext() ! Needs no temporary - was OK
if (any (a .ne. check)) call myabort (15)
a = FIVE
a = i_ext() ! Needs no temporary - was OK
if (any (a .ne. check)) call myabort (16)
c = FIVE
! This aliases 'c' through the common block.
c = j()
if (any (c .ne. check)) call myabort (7)
call aaa
call tobias
if (abort_flag) call abort
contains
function f()
integer :: f(ONE)
f = -FIVE
f = a - f
end function f
function g()
integer :: g(ONE)
g = -FIVE
g = foo_a - g
end function g
function h()
integer :: h(ONE)
h = -FIVE
h = FIVE - h
end function h
function i() result (h)
integer :: h(ONE)
h = -FIVE
h = FIVE - h
end function i
function j()
common /foo_bar/ cc
integer :: j(ONE), cc(ONE)
j = -FIVE
j = cc - j
end function j
subroutine aaa()
d = TEN - TWO
! This aliases 'd' through 'get_d'.
d = bbb()
if (any (d .ne. check)) call myabort (8)
end subroutine aaa
function bbb()
integer :: bbb(ONE)
bbb = TWO
bbb = bbb + get_d()
end function bbb
function get_d()
integer :: get_d(ONE)
get_d = d
end function get_d
end program test
|
