| ! { dg-do run } |
| ! |
| ! This program checks that passing allocatable and pointer scalars to |
| ! and from Fortran functions with C binding works. |
| |
| module mm |
| use iso_c_binding |
| type, bind (c) :: m |
| integer(C_INT) :: i, j |
| end type |
| |
| integer, parameter :: imagic=-1, jmagic=42 |
| end module |
| |
| program testit |
| use iso_c_binding |
| use mm |
| implicit none |
| |
| type(m), allocatable :: a |
| type(m), target :: t |
| type(m), pointer :: p |
| |
| p => NULL() |
| |
| call testc (a, t, p) |
| call testf (a, t, p) |
| |
| contains |
| |
| ! C binding version |
| |
| subroutine checkc (a, t, p, initp) bind (c) |
| use iso_c_binding |
| use mm |
| type(m), allocatable :: a |
| type(m), target :: t |
| type(m), pointer :: p |
| logical, value :: initp |
| |
| if (initp) then |
| if (.not. allocated (a)) stop 101 |
| if (a%i .ne. imagic) stop 102 |
| if (a%j .ne. jmagic) stop 103 |
| if (.not. associated (p)) stop 104 |
| if (.not. associated (p, t)) stop 105 |
| if (p%i .ne. imagic) stop 106 |
| if (p%j .ne. jmagic) stop 107 |
| else |
| if (allocated (a)) stop 108 |
| if (associated (p)) stop 109 |
| end if |
| |
| if (rank (a) .ne. 0) stop 110 |
| if (rank (t) .ne. 0) stop 111 |
| if (rank (p) .ne. 0) stop 112 |
| |
| end subroutine |
| |
| ! Fortran binding version |
| subroutine checkf (a, t, p, initp) |
| use iso_c_binding |
| use mm |
| type(m), allocatable :: a |
| type(m), target :: t |
| type(m), pointer :: p |
| logical, value :: initp |
| |
| if (initp) then |
| if (.not. allocated (a)) stop 201 |
| if (a%i .ne. imagic) stop 202 |
| if (a%j .ne. jmagic) stop 203 |
| if (.not. associated (p)) stop 204 |
| if (.not. associated (p, t)) stop 205 |
| if (p%i .ne. imagic) stop 206 |
| if (p%j .ne. jmagic) stop 207 |
| else |
| if (allocated (a)) stop 208 |
| if (associated (p)) stop 209 |
| end if |
| |
| if (rank (a) .ne. 0) stop 210 |
| if (rank (t) .ne. 0) stop 211 |
| if (rank (p) .ne. 0) stop 212 |
| |
| end subroutine |
| |
| ! C binding version |
| subroutine testc (a, t, p) bind (c) |
| use iso_c_binding |
| use mm |
| type(m), allocatable :: a |
| type(m), target :: t |
| type(m), pointer :: p |
| |
| ! Call both the C and Fortran binding check functions |
| call checkc (a, t, p, .false.) |
| call checkf (a, t, p, .false.) |
| |
| ! Allocate/associate and check again. |
| allocate (a) |
| a%i = imagic |
| a%j = jmagic |
| p => t |
| t%i = imagic |
| t%j = jmagic |
| call checkc (a, t, p, .true.) |
| call checkf (a, t, p, .true.) |
| |
| ! Reset and check a third time. |
| deallocate (a) |
| p => NULL () |
| call checkc (a, t, p, .false.) |
| call checkf (a, t, p, .false.) |
| |
| end subroutine |
| |
| ! Fortran binding version |
| subroutine testf (a, t, p) |
| use iso_c_binding |
| use mm |
| type(m), allocatable :: a |
| type(m), target :: t |
| type(m), pointer :: p |
| |
| ! Call both the C and Fortran binding check functions |
| call checkc (a, t, p, .false.) |
| call checkf (a, t, p, .false.) |
| |
| ! Allocate/associate and check again. |
| allocate (a) |
| a%i = imagic |
| a%j = jmagic |
| p => t |
| t%i = imagic |
| t%j = jmagic |
| call checkc (a, t, p, .true.) |
| call checkf (a, t, p, .true.) |
| |
| ! Reset and check a third time. |
| deallocate (a) |
| p => NULL () |
| call checkc (a, t, p, .false.) |
| call checkf (a, t, p, .false.) |
| |
| end subroutine |
| |
| end program |
