gcc/testsuite/gfortran.dg/pointer_array_7.f90

   1 ! { dg-do run }
   2 !
   3 ! Test for the fix for PR34640. In this case, final testing of the
   4 ! patch revealed that in some cases the actual descriptor was not
   5 ! being passed to procedure dummy pointers.
   6 !
   7 ! Contributed by Thomas Koenig  <tkoenig@netcologne.de>
   8 !
   9 module x
  10   use iso_c_binding
  11   implicit none
  12   type foo
  13      complex :: c
  14      integer :: i
  15   end type foo
  16 contains
  17   subroutine printit(c, a)
  18     complex, pointer, dimension(:) :: c
  19     integer :: i
  20     integer(kind=c_intptr_t) :: a
  21     a = transfer(c_loc(c(2)),a)
  22   end subroutine printit
  23 end module x
  24
  25 program main
  26   use x
  27   use iso_c_binding
  28   implicit none
  29   type(foo), dimension(5), target :: a
  30   integer :: i
  31   complex, dimension(:), pointer :: pc
  32   integer(kind=c_intptr_t) :: s1, s2, s3
  33   a%i = 0
  34   do i=1,5
  35      a(i)%c = cmplx(i**2,i)
  36   end do
  37   pc => a%c
  38   call printit(pc, s3)
  39
  40   s1 = transfer(c_loc(a(2)%c),s1)
  41   if (s1 /= s3) STOP 1
  42
  43   s2 = transfer(c_loc(pc(2)),s2)
  44   if (s2 /= s3) STOP 2
  45
  46 end program main