File: pointer_array_7.f90

package info (click to toggle)
gcc-arm-none-eabi 15%3A12.2.rel1-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 959,712 kB
  • sloc: cpp: 3,275,382; ansic: 2,061,766; ada: 840,956; f90: 208,513; makefile: 76,132; asm: 73,433; xml: 50,448; exp: 34,146; sh: 32,436; objc: 15,637; fortran: 14,012; python: 11,991; pascal: 6,787; awk: 4,779; perl: 3,054; yacc: 338; ml: 285; lex: 201; haskell: 122
file content (46 lines) | stat: -rw-r--r-- 977 bytes parent folder | download | duplicates (3) 
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
 
! { dg-do run }
!
! Test for the fix for PR34640. In this case, final testing of the
! patch revealed that in some cases the actual descriptor was not
! being passed to procedure dummy pointers.
!
! Contributed by Thomas Koenig  <tkoenig@netcologne.de>
!
module x
  use iso_c_binding
  implicit none
  type foo
     complex :: c
     integer :: i
  end type foo
contains
  subroutine printit(c, a)
    complex, pointer, dimension(:) :: c
    integer :: i
    integer(kind=c_intptr_t) :: a
    a = transfer(c_loc(c(2)),a)
  end subroutine printit
end module x

program main
  use x
  use iso_c_binding
  implicit none
  type(foo), dimension(5), target :: a
  integer :: i
  complex, dimension(:), pointer :: pc
  integer(kind=c_intptr_t) :: s1, s2, s3
  a%i = 0
  do i=1,5
     a(i)%c = cmplx(i**2,i)
  end do
  pc => a%c
  call printit(pc, s3)

  s1 = transfer(c_loc(a(2)%c),s1)
  if (s1 /= s3) STOP 1

  s2 = transfer(c_loc(pc(2)),s2)
  if (s2 /= s3) STOP 2

end program main