summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
diff options
context:
space:
mode:
authorupstream source tree <ports@midipix.org>2015-03-15 20:14:05 -0400
committerupstream source tree <ports@midipix.org>2015-03-15 20:14:05 -0400
commit554fd8c5195424bdbcabf5de30fdc183aba391bd (patch)
tree976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
downloadcbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2
cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90')
-rw-r--r--gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90164
1 files changed, 164 insertions, 0 deletions
diff --git a/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
new file mode 100644
index 000000000..d8899d2ec
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
@@ -0,0 +1,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" } }