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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
! { 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
|
