summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
blob: d8899d2ecf877b7708e6f5bce42315b69f41b8c8 (plain)
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
164
! { 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
! { dg-final { cleanup-modules "foo" } }