gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90

   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 !
  13 module 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.
  21 contains
  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
  38 end module foo
  39
  40 function h_ext()
  41   use foo
  42   integer :: h_ext(ONE)
  43   h_ext = -FIVE
  44   h_ext = FIVE - h_ext
  45 end function h_ext
  46
  47 function i_ext() result (h)
  48   use foo
  49   integer :: h(ONE)
  50   h = -FIVE
  51   h = FIVE - h
  52 end function i_ext
  53
  54 subroutine tobias
  55   use foo
  56   integer :: a(ONE)
  57   a = FIVE
  58   call sub1(a)
  59   if (any (a .ne. check)) call myabort (1)
  60 contains
  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
  71 end subroutine tobias
  72
  73 program 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
 121 contains
 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
 163 end program test