FortranGIS Version 3.0
fortranc.F90
1! Copyright 2011 Davide Cesari <dcesari69 at gmail dot com>
2!
3! This file is part of FortranGIS.
4!
5! FortranGIS is free software: you can redistribute it and/or modify
6! it under the terms of the GNU Lesser General Public License as
7! published by the Free Software Foundation, either version 3 of the
8! License, or (at your option) any later version.
9!
10! FortranGIS is distributed in the hope that it will be useful, but
11! WITHOUT ANY WARRANTY; without even the implied warranty of
12! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13! Lesser General Public License for more details.
14!
15! You should have received a copy of the GNU Lesser General Public
16! License along with FortranGIS. If not, see
17! <http://www.gnu.org/licenses/>.
18#include "config.h"
19
32MODULE fortranc
33use,INTRINSIC :: iso_c_binding
34#ifdef WITH_VARYING_STRING
35USE iso_varying_string
36#endif
37IMPLICIT NONE
38
39
70TYPE c_ptr_ptr
71 PRIVATE
72 TYPE(c_ptr),POINTER :: elem(:) => null()
73 CHARACTER(len=1),POINTER :: buffer(:) => null()
74END TYPE c_ptr_ptr
75
79INTERFACE strlen
80 MODULE PROCEDURE strlen_char, strlen_chararr, strlen_intarr, &
81 strlen_ptr
82#ifdef WITH_VARYING_STRING
83 MODULE PROCEDURE strlen_var_str
84#endif
85END INTERFACE
86
109INTERFACE strtofchar
110 MODULE PROCEDURE strtofchar_char, strtofchar_chararr, strtofchar_intarr, &
111 strtofchar_ptr_2
112END INTERFACE
113
120INTERFACE c_ptr_ptr_new
121 MODULE PROCEDURE c_ptr_ptr_new_from_c, c_ptr_ptr_new_from_fchar
122END INTERFACE c_ptr_ptr_new
123
124INTERFACE ASSIGNMENT(=)
125 MODULE PROCEDURE strtofchararr_assign
126END INTERFACE ASSIGNMENT(=)
127
128PRIVATE
129PUBLIC strlen, strtofchar, fchartostr, fchartrimtostr, ASSIGNMENT(=)
130PUBLIC c_ptr_ptr, c_ptr_ptr_new, c_ptr_ptr_getsize, c_ptr_ptr_getptr, c_ptr_ptr_getobject
131
132CONTAINS
133
134
135PURE FUNCTION strlen_char(string) RESULT(strlen)
136#ifdef DLL_EXPORT
137!GCC$ ATTRIBUTES DLLEXPORT :: strlen_char
138#endif
139CHARACTER(kind=c_char,len=*),INTENT(in) :: string
140INTEGER :: strlen
141
142INTEGER :: i
143
144DO i = 1, len(string)
145 IF (string(i:i) == char(0)) EXIT
146ENDDO
147strlen = i - 1
148
149END FUNCTION strlen_char
150
151
152PURE FUNCTION strlen_chararr(string) RESULT(strlen)
153#ifdef DLL_EXPORT
154!GCC$ ATTRIBUTES DLLEXPORT :: strlen_chararr
155#endif
156CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
157INTEGER :: strlen
158
159INTEGER :: i
160
161DO i = 1, SIZE(string)
162 IF (string(i) == char(0)) EXIT
163ENDDO
164strlen = i - 1
165
166END FUNCTION strlen_chararr
167
168
169PURE FUNCTION strlen_intarr(string) RESULT(strlen)
170#ifdef DLL_EXPORT
171!GCC$ ATTRIBUTES DLLEXPORT :: strlen_intarr
172#endif
173INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
174INTEGER :: strlen
175
176INTEGER :: i
177
178DO i = 1, SIZE(string)
179 IF (string(i) == 0) EXIT
180ENDDO
181strlen = i - 1
182
183END FUNCTION strlen_intarr
184
186FUNCTION strlen_ptr(string) RESULT(strlen)
187#ifdef DLL_EXPORT
188!GCC$ ATTRIBUTES DLLEXPORT :: strlen_ptr
189#endif
190TYPE(c_ptr),INTENT(in) :: string
191INTEGER :: strlen
192
193INTEGER(kind=c_signed_char),POINTER :: pstring(:)
194INTEGER :: i
195
196IF (c_associated(string)) THEN ! conflicts with PURE
197! null C pointer does not produce unassociated Fortran pointer with Intel
198 CALL c_f_pointer(string, pstring, (/huge(i)/))
199! IF (ASSOCIATED(pstring)) THEN
200 DO i = 1, SIZE(pstring)
201 IF (pstring(i) == 0) EXIT
202 ENDDO
203 strlen = i - 1
204ELSE
205 strlen = 0
206ENDIF
207
208END FUNCTION strlen_ptr
209
210
211#ifdef WITH_VARYING_STRING
212PURE FUNCTION strlen_var_str(string) RESULT(strlen)
213#ifdef DLL_EXPORT
214!GCC$ ATTRIBUTES DLLEXPORT :: strlen_var_str
215#endif
216TYPE(varying_string),INTENT(in) :: string
217INTEGER :: strlen
218
219strlen = len(string)
220
221END FUNCTION strlen_var_str
222#endif
223
224
225FUNCTION strtofchar_char(string) RESULT(fchar)
226#ifdef DLL_EXPORT
227!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_char
228#endif
229CHARACTER(kind=c_char,len=*),INTENT(in) :: string
230CHARACTER(len=strlen(string)) :: fchar
231
232fchar(:) = string(1:len(fchar))
233
234END FUNCTION strtofchar_char
235
236
237FUNCTION strtofchar_chararr(string) RESULT(fchar)
238#ifdef DLL_EXPORT
239!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
240#endif
241CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
242CHARACTER(len=strlen(string)) :: fchar
243
244INTEGER :: i
245
246DO i = 1, len(fchar)
247 fchar(i:i) = string(i)
248ENDDO
249
250END FUNCTION strtofchar_chararr
251
252
253FUNCTION strtofchar_intarr(string) RESULT(fchar)
254#ifdef DLL_EXPORT
255!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_intarr
256#endif
257INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
258CHARACTER(len=strlen(string)) :: fchar
259
260fchar(:) = transfer(string(1:len(fchar)), fchar)
261
262END FUNCTION strtofchar_intarr
263
264
265! this unfortunately works only with gfortran where c_f_pointer is
266! "erroneously" declared as PURE thus strlen_ptr can be PURE as well
267
268!FUNCTION strtofchar_ptr(string) RESULT(fchar)
269!TYPE(c_ptr),INTENT(in) :: string
270!CHARACTER(len=strlen(string)) :: fchar
271!
272!CHARACTER(len=strlen(string)),POINTER :: pfchar
273!
274!IF (C_ASSOCIATED(string)) THEN
275! CALL c_f_pointer(string, pfchar)
276! fchar(:) = pfchar(:)
277!!ELSE
278!! silently return an empty string probably useless because
279!! strlen is zero in this case (to be tested)
280!! fchar = ''
281!ENDIF
282!
283!END FUNCTION strtofchar_ptr
284
285
286FUNCTION strtofchar_ptr_2(string, fixlen) RESULT(fchar)
287#ifdef DLL_EXPORT
288!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_ptr_2
289#endif
290TYPE(c_ptr),INTENT(in) :: string
291INTEGER,INTENT(in) :: fixlen
292CHARACTER(len=fixlen) :: fchar
293
294CHARACTER(len=fixlen),POINTER :: pfchar
295INTEGER :: safelen
296
297safelen = min(strlen(string), fixlen)
298
299fchar = ''
300IF (c_associated(string)) THEN
301 CALL c_f_pointer(string, pfchar)
302 fchar(1:safelen) = pfchar(1:safelen)
303ENDIF
304
305END FUNCTION strtofchar_ptr_2
306
307
312FUNCTION fchartostr(fchar) RESULT(string)
313#ifdef DLL_EXPORT
314!GCC$ ATTRIBUTES DLLEXPORT :: fchartostr
315#endif
316CHARACTER(len=*),INTENT(in) :: fchar
317CHARACTER(kind=c_char,len=LEN(fchar)+1) :: string
318
319string = fchar//char(0)
320
321END FUNCTION fchartostr
322
323
329FUNCTION fchartrimtostr(fchar) RESULT(string)
330#ifdef DLL_EXPORT
331!GCC$ ATTRIBUTES DLLEXPORT :: fchartrimtostr
332#endif
333CHARACTER(len=*),INTENT(in) :: fchar
334CHARACTER(kind=c_char,len=LEN_TRIM(fchar)+1) :: string
335
336string = trim(fchar)//char(0)
337
338END FUNCTION fchartrimtostr
339
340
341SUBROUTINE strtofchararr_assign(fchar, string)
342#ifdef DLL_EXPORT
343!GCC$ ATTRIBUTES DLLEXPORT :: strtofchararr_assign
344#endif
345CHARACTER(kind=c_char,len=1),ALLOCATABLE,INTENT(out) :: fchar(:)
346TYPE(c_ptr),INTENT(in) :: string
347
348CHARACTER(kind=c_char),POINTER :: pstring(:)
349INTEGER :: l
350
351l = strlen(string)
352CALL c_f_pointer(string, pstring, (/l/))
353ALLOCATE(fchar(l))
354fchar(:) = pstring(:)
356END SUBROUTINE strtofchararr_assign
357
358
365FUNCTION c_ptr_ptr_new_from_c(c_ptr_ptr_c) RESULT(this)
366#ifdef DLL_EXPORT
367!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_new_from_c
368#endif
369TYPE(c_ptr),VALUE :: c_ptr_ptr_c
370TYPE(c_ptr_ptr) :: this
371
372INTEGER :: i
373TYPE(c_ptr),POINTER :: charp(:)
374
375IF (c_associated(c_ptr_ptr_c)) THEN
376 ! HUGE() here is ugly, but we must set a finite size
377 CALL c_f_pointer(c_ptr_ptr_c, charp, (/huge(1)/))
378 DO i = 1, SIZE(charp)
379 IF (.NOT.c_associated(charp(i))) THEN
380 CALL c_f_pointer(c_ptr_ptr_c, this%elem, (/i/))
381 RETURN
382 ENDIF
383 ENDDO
384ENDIF
385END FUNCTION c_ptr_ptr_new_from_c
386
387
394FUNCTION c_ptr_ptr_new_from_fchar(fchar) RESULT(this)
395CHARACTER(len=*) :: fchar(:)
396TYPE(c_ptr_ptr) :: this
397
398INTEGER :: i, j, totlen
399
400totlen = 0
401DO i = 1, SIZE(fchar)
402 totlen = totlen + len_trim(fchar(i)) + 1
403ENDDO
404ALLOCATE(this%buffer(totlen), this%elem(SIZE(fchar) + 1))
405totlen = 1
406DO i = 1, SIZE(fchar)
407 this%elem(i) = c_loc(this%buffer(totlen))
408 DO j = 1, len_trim(fchar(i))
409 this%buffer(totlen) = fchar(i)(j:j)
410 totlen = totlen + 1
411 ENDDO
412 this%buffer(totlen) = char(0)
413 totlen = totlen + 1
414ENDDO
415this%elem(i) = c_null_ptr
416
417END FUNCTION c_ptr_ptr_new_from_fchar
418
419
423FUNCTION c_ptr_ptr_getsize(this)
424#ifdef DLL_EXPORT
425!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getsize
426#endif
427TYPE(c_ptr_ptr),INTENT(in) :: this
428INTEGER :: c_ptr_ptr_getsize
429
430IF (ASSOCIATED(this%elem)) THEN
431 c_ptr_ptr_getsize = SIZE(this%elem) - 1
432ELSE
433 c_ptr_ptr_getsize = 0
434ENDIF
435
436END FUNCTION c_ptr_ptr_getsize
437
446FUNCTION c_ptr_ptr_getptr(this, n)
447#ifdef DLL_EXPORT
448!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getptr
449#endif
450TYPE(c_ptr_ptr),INTENT(in) :: this
451INTEGER,INTENT(in) :: n
452TYPE(c_ptr) :: c_ptr_ptr_getptr
453
454c_ptr_ptr_getptr = c_null_ptr
455IF (ASSOCIATED(this%elem)) THEN
456 IF (n > 0 .AND. n <= SIZE(this%elem)) THEN
457 c_ptr_ptr_getptr = this%elem(n)
458 ENDIF
459ENDIF
461END FUNCTION c_ptr_ptr_getptr
462
463
467FUNCTION c_ptr_ptr_getobject(this)
468TYPE(c_ptr_ptr),INTENT(in) :: this
469TYPE(c_ptr) :: c_ptr_ptr_getobject
470
471c_ptr_ptr_getobject = c_null_ptr
472IF (ASSOCIATED(this%elem)) THEN
473 c_ptr_ptr_getobject = c_loc(this%elem(1))
474ENDIF
475
476END FUNCTION c_ptr_ptr_getobject
477
478END MODULE fortranc
Constructor for a c_ptr_ptr object.
Definition: fortranc.F90:185
Equivalent of the strlen C function.
Definition: fortranc.F90:147
Convert a null-terminated C string into a Fortran CHARACTER variable of the proper length.
Definition: fortranc.F90:174
Utility module for supporting Fortran 2003 C language interface module.
Definition: fortranc.F90:103
Fortran derived type for handling void**, char**, etc C objects (pointer to pointer or array of point...
Definition: fortranc.F90:138