1! { dg-do run }
2! Tests the fic for PR44582, where gfortran was found to
3! produce an incorrect result when the result of a function
4! was aliased by a host or use associated variable, to which
5! the function is assigned. In these cases a temporary is
6! required in the function assignments. The check has to be
7! rather restrictive.  Whilst the cases marked below might
8! not need temporaries, the TODOs are going to be tough.
9!
10! Reported by Yin Ma <yin@absoft.com> and
11! elaborated by Tobias Burnus <burnus@gcc.gnu.org>
12!
13module foo
14  INTEGER, PARAMETER :: ONE = 1
15  INTEGER, PARAMETER :: TEN = 10
16  INTEGER, PARAMETER :: FIVE = TEN/2
17  INTEGER, PARAMETER :: TWO = 2
18  integer :: foo_a(ONE)
19  integer :: check(ONE) = TEN
20  LOGICAL :: abort_flag = .false.
21contains
22  function foo_f()
23     integer :: foo_f(ONE)
24     foo_f = -FIVE
25     foo_f = foo_a - foo_f
26  end function foo_f
27  subroutine bar
28    foo_a = FIVE
29! This aliases 'foo_a' by host association.
30    foo_a = foo_f ()
31    if (any (foo_a .ne. check)) call myabort (0)
32  end subroutine bar
33  subroutine myabort(fl)
34    integer :: fl
35    print *, fl
36    abort_flag = .true.
37  end subroutine myabort
38end module foo
39
40function h_ext()
41  use foo
42  integer :: h_ext(ONE)
43  h_ext = -FIVE
44  h_ext = FIVE - h_ext
45end function h_ext
46
47function i_ext() result (h)
48  use foo
49  integer :: h(ONE)
50  h = -FIVE
51  h = FIVE - h
52end function i_ext
53
54subroutine tobias
55  use foo
56  integer :: a(ONE)
57  a = FIVE
58  call sub1(a)
59  if (any (a .ne. check)) call myabort (1)
60contains
61  subroutine sub1(x)
62    integer :: x(ONE)
63! 'x' is aliased by host association in 'f'.
64    x = f()
65  end subroutine sub1
66  function f()
67    integer :: f(ONE)
68    f = ONE
69    f = a + FIVE
70  end function f
71end subroutine tobias
72
73program test
74  use foo
75  implicit none
76  common /foo_bar/ c
77  integer :: a(ONE), b(ONE), c(ONE), d(ONE)
78  interface
79    function h_ext()
80      use foo
81      integer :: h_ext(ONE)
82    end function h_ext
83  end interface
84  interface
85    function i_ext() result (h)
86      use foo
87      integer :: h(ONE)
88    end function i_ext
89  end interface
90
91  a = FIVE
92! This aliases 'a' by host association
93  a = f()
94  if (any (a .ne. check)) call myabort (2)
95  a = FIVE
96  if (any (f() .ne. check)) call myabort (3)
97  call bar
98  foo_a = FIVE
99! This aliases 'foo_a' by host association.
100  foo_a = g ()
101  if (any (foo_a .ne. check)) call myabort (4)
102  a = FIVE
103  a = h()           ! TODO: Needs no temporary
104  if (any (a .ne. check)) call myabort (5)
105  a = FIVE
106  a = i()           ! TODO: Needs no temporary
107  if (any (a .ne. check)) call myabort (6)
108  a = FIVE
109  a = h_ext()       ! Needs no temporary - was OK
110  if (any (a .ne. check)) call myabort (15)
111  a = FIVE
112  a = i_ext()       ! Needs no temporary - was OK
113  if (any (a .ne. check)) call myabort (16)
114  c = FIVE
115! This aliases 'c' through the common block.
116  c = j()
117  if (any (c .ne. check)) call myabort (7)
118  call aaa
119  call tobias
120  if (abort_flag) call abort
121contains
122  function f()
123     integer :: f(ONE)
124     f = -FIVE
125     f = a - f
126  end function f
127  function g()
128     integer :: g(ONE)
129     g = -FIVE
130     g = foo_a - g
131  end function g
132  function h()
133     integer :: h(ONE)
134     h = -FIVE
135     h = FIVE - h
136  end function h
137  function i() result (h)
138     integer :: h(ONE)
139     h = -FIVE
140     h = FIVE - h
141  end function i
142  function j()
143     common /foo_bar/ cc
144     integer :: j(ONE), cc(ONE)
145     j = -FIVE
146     j = cc - j
147  end function j
148  subroutine aaa()
149    d = TEN - TWO
150! This aliases 'd' through 'get_d'.
151    d = bbb()
152    if (any (d .ne. check)) call myabort (8)
153  end subroutine aaa
154  function bbb()
155    integer :: bbb(ONE)
156    bbb = TWO
157    bbb = bbb + get_d()
158  end function bbb
159  function get_d()
160    integer :: get_d(ONE)
161    get_d = d
162  end function get_d
163end program test
164