gcc/testsuite/gfortran.dg/ptr-func-3.f90

   1 ! { dg-do run }
   2 ! PR fortran/96896
   3
   4 call test1
   5 call reshape_test
   6 end
   7
   8 subroutine test1
   9 implicit none
  10 integer, target :: B
  11 integer, pointer :: A(:)
  12 allocate(A(5))
  13 A = 1
  14 B = 10
  15 get_A() = get_B()
  16 if (any (A /= 10)) stop 1
  17 get_A() = get_A()
  18 if (any (A /= 10)) stop 2
  19 deallocate(A)
  20 contains
  21   function get_A()
  22     integer, pointer :: get_A(:)
  23     get_A => A
  24   end
  25   function get_B()
  26     integer, pointer :: get_B
  27     get_B => B
  28   end
  29 end
  30
  31 subroutine reshape_test
  32     implicit none
  33     real, target, dimension (1:9) :: b
  34     integer :: i
  35     b = 1.0
  36     myshape(b) = 3.0
  37     do i = 1, 3
  38       myfunc (b,i,2) = b(i) + i
  39       b(i) = b(i) + 2.0
  40     end do
  41     if (any (b /= [real::5,5,5,4,5,6,3,3,3])) stop 3
  42 contains
  43   function myfunc(b,i,j)
  44     real, target, dimension (1:9) :: b
  45     real, pointer :: myfunc
  46     real, pointer :: p(:,:)
  47     integer :: i,j
  48     p => myshape(b)
  49     myfunc => p(i,j)
  50   end function myfunc
  51   function myshape(b)
  52     real, target, dimension (1:9) :: b
  53     real, pointer :: myshape(:,:)
  54     myshape(1:3,1:3) => b
  55   end function myshape
  56 end subroutine reshape_test