FortranGIS  Version2.5
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 
32 MODULE fortranc
33 use,INTRINSIC :: iso_c_binding
34 #ifdef WITH_VARYING_STRING
35 USE iso_varying_string
36 #endif
37 IMPLICIT NONE
38 
39 
68 TYPE c_ptr_ptr
69  PRIVATE
70  TYPE(c_ptr),POINTER :: elem(:) => null()
71  CHARACTER(len=1),POINTER :: buffer(:) => null()
72 END TYPE c_ptr_ptr
73 
77 INTERFACE strlen
78  MODULE PROCEDURE strlen_char, strlen_chararr, strlen_intarr, &
79  strlen_ptr
80 #ifdef WITH_VARYING_STRING
81  MODULE PROCEDURE strlen_var_str
82 #endif
83 END INTERFACE
84 
103 INTERFACE strtofchar
104  MODULE PROCEDURE strtofchar_char, strtofchar_chararr, strtofchar_intarr, &
105  strtofchar_ptr_2
106 END INTERFACE
107 
114 INTERFACE c_ptr_ptr_new
115  MODULE PROCEDURE c_ptr_ptr_new_from_c, c_ptr_ptr_new_from_fchar
116 END INTERFACE c_ptr_ptr_new
117 
118 INTERFACE assignment(=)
119  MODULE PROCEDURE strtofchararr_assign
120 END INTERFACE ASSIGNMENT(=)
121 
122 PRIVATE
123 PUBLIC strlen, strtofchar, fchartostr, fchartrimtostr, assignment(=)
124 PUBLIC c_ptr_ptr, c_ptr_ptr_new, c_ptr_ptr_getsize, c_ptr_ptr_getptr, c_ptr_ptr_getobject
125 
126 CONTAINS
127 
128 
129 PURE FUNCTION strlen_char(string) RESULT(strlen)
130 #ifdef DLL_EXPORT
131 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_char
132 #endif
133 CHARACTER(kind=c_char,len=*),INTENT(in) :: string
134 INTEGER :: strlen
135 
136 INTEGER :: i
137 
138 DO i = 1, len(string)
139  IF (string(i:i) == char(0)) EXIT
140 ENDDO
141 strlen = i - 1
143 END FUNCTION strlen_char
144 
145 
146 PURE FUNCTION strlen_chararr(string) RESULT(strlen)
147 #ifdef DLL_EXPORT
148 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_chararr
149 #endif
150 CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
151 INTEGER :: strlen
152 
153 INTEGER :: i
154 
155 DO i = 1, SIZE(string)
156  IF (string(i) == char(0)) EXIT
157 ENDDO
158 strlen = i - 1
159 
160 END FUNCTION strlen_chararr
161 
162 
163 PURE FUNCTION strlen_intarr(string) RESULT(strlen)
164 #ifdef DLL_EXPORT
165 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_intarr
166 #endif
167 INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
168 INTEGER :: strlen
169 
170 INTEGER :: i
171 
172 DO i = 1, SIZE(string)
173  IF (string(i) == 0) EXIT
174 ENDDO
175 strlen = i - 1
177 END FUNCTION strlen_intarr
178 
179 
180 FUNCTION strlen_ptr(string) RESULT(strlen)
181 #ifdef DLL_EXPORT
182 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_ptr
183 #endif
184 TYPE(c_ptr),INTENT(in) :: string
185 INTEGER :: strlen
186 
187 INTEGER(kind=c_signed_char),POINTER :: pstring(:)
188 INTEGER :: i
189 
190 IF (c_associated(string)) THEN ! conflicts with PURE
191 ! null C pointer does not produce unassociated Fortran pointer with Intel
192  CALL c_f_pointer(string, pstring, (/huge(i)/))
193 ! IF (ASSOCIATED(pstring)) THEN
194  DO i = 1, SIZE(pstring)
195  IF (pstring(i) == 0) EXIT
196  ENDDO
197  strlen = i - 1
198 ELSE
199  strlen = 0
200 ENDIF
201 
202 END FUNCTION strlen_ptr
203 
204 
205 #ifdef WITH_VARYING_STRING
206 PURE FUNCTION strlen_var_str(string) RESULT(strlen)
207 #ifdef DLL_EXPORT
208 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_var_str
209 #endif
210 TYPE(varying_string),INTENT(in) :: string
211 INTEGER :: strlen
212 
213 strlen = len(string)
214 
215 END FUNCTION strlen_var_str
216 #endif
217 
218 
219 FUNCTION strtofchar_char(string) RESULT(fchar)
220 #ifdef DLL_EXPORT
221 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_char
222 #endif
223 CHARACTER(kind=c_char,len=*),INTENT(in) :: string
224 CHARACTER(len=strlen(string)) :: fchar
225 
226 fchar(:) = string(1:len(fchar))
227 
228 END FUNCTION strtofchar_char
229 
230 
231 FUNCTION strtofchar_chararr(string) RESULT(fchar)
232 #ifdef DLL_EXPORT
233 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
234 #endif
235 CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
236 CHARACTER(len=strlen(string)) :: fchar
237 
238 INTEGER :: i
239 
240 DO i = 1, len(fchar)
241  fchar(i:i) = string(i)
242 ENDDO
243 
244 END FUNCTION strtofchar_chararr
245 
246 
247 FUNCTION strtofchar_intarr(string) RESULT(fchar)
248 #ifdef DLL_EXPORT
249 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_intarr
250 #endif
251 INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
252 CHARACTER(len=strlen(string)) :: fchar
253 
254 fchar(:) = transfer(string(1:len(fchar)), fchar)
255 
256 END FUNCTION strtofchar_intarr
257 
258 
259 ! this unfortunately works only with gfortran where c_f_pointer is
260 ! "erroneously" declared as PURE thus strlen_ptr can be PURE as well
261 
262 !FUNCTION strtofchar_ptr(string) RESULT(fchar)
263 !TYPE(c_ptr),INTENT(in) :: string
264 !CHARACTER(len=strlen(string)) :: fchar
265 !
266 !CHARACTER(len=strlen(string)),POINTER :: pfchar
267 !
268 !IF (C_ASSOCIATED(string)) THEN
269 ! CALL c_f_pointer(string, pfchar)
270 ! fchar(:) = pfchar(:)
271 !!ELSE
272 !! silently return an empty string probably useless because
273 !! strlen is zero in this case (to be tested)
274 !! fchar = ''
275 !ENDIF
276 !
277 !END FUNCTION strtofchar_ptr
278 
279 
280 FUNCTION strtofchar_ptr_2(string, fixlen) RESULT(fchar)
281 #ifdef DLL_EXPORT
282 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_ptr_2
283 #endif
284 TYPE(c_ptr),INTENT(in) :: string
285 INTEGER,INTENT(in) :: fixlen
286 CHARACTER(len=fixlen) :: fchar
287 
288 CHARACTER(len=fixlen),POINTER :: pfchar
289 INTEGER :: safelen
290 
291 safelen = min(strlen(string), fixlen)
292 
293 fchar = ''
294 IF (c_associated(string)) THEN
295  CALL c_f_pointer(string, pfchar)
296  fchar(1:safelen) = pfchar(1:safelen)
297 ENDIF
298 
299 END FUNCTION strtofchar_ptr_2
300 
301 
306 FUNCTION fchartostr(fchar) RESULT(string)
307 #ifdef DLL_EXPORT
308 !GCC$ ATTRIBUTES DLLEXPORT :: fchartostr
309 #endif
310 CHARACTER(len=*),INTENT(in) :: fchar
311 CHARACTER(kind=c_char,len=LEN(fchar)+1) :: string
312 
313 string = fchar//char(0)
314 
315 END FUNCTION fchartostr
316 
317 
323 FUNCTION fchartrimtostr(fchar) RESULT(string)
324 #ifdef DLL_EXPORT
325 !GCC$ ATTRIBUTES DLLEXPORT :: fchartrimtostr
326 #endif
327 CHARACTER(len=*),INTENT(in) :: fchar
328 CHARACTER(kind=c_char,len=LEN_TRIM(fchar)+1) :: string
329 
330 string = trim(fchar)//char(0)
331 
332 END FUNCTION fchartrimtostr
334 
335 SUBROUTINE strtofchararr_assign(fchar, string)
336 #ifdef DLL_EXPORT
337 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
338 #endif
339 CHARACTER(kind=c_char,len=1),ALLOCATABLE,INTENT(out) :: fchar(:)
340 TYPE(c_ptr),INTENT(in) :: string
341 
342 CHARACTER(kind=c_char),POINTER :: pstring(:)
343 INTEGER :: l
344 
345 l = strlen(string)
346 CALL c_f_pointer(string, pstring, (/l/))
347 ALLOCATE(fchar(l))
348 fchar(:) = pstring(:)
349 
350 END SUBROUTINE strtofchararr_assign
351 
352 
359 FUNCTION c_ptr_ptr_new_from_c(c_ptr_ptr_c) RESULT(this)
360 #ifdef DLL_EXPORT
361 !GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_new_from_c
362 #endif
363 TYPE(c_ptr),VALUE :: c_ptr_ptr_c
364 TYPE(c_ptr_ptr) :: this
365 
366 INTEGER :: i
367 TYPE(c_ptr),POINTER :: charp(:)
368 
369 IF (c_associated(c_ptr_ptr_c)) THEN
370  ! HUGE() here is ugly, but we must set a finite size
371  CALL c_f_pointer(c_ptr_ptr_c, charp, (/huge(1)/))
372  DO i = 1, SIZE(charp)
373  IF (.NOT.c_associated(charp(i))) THEN
374  CALL c_f_pointer(c_ptr_ptr_c, this%elem, (/i/))
375  RETURN
376  ENDIF
377  ENDDO
378 ENDIF
379 END FUNCTION c_ptr_ptr_new_from_c
380 
381 
388 FUNCTION c_ptr_ptr_new_from_fchar(fchar) RESULT(this)
389 CHARACTER(len=*) :: fchar(:)
390 TYPE(c_ptr_ptr) :: this
391 
392 INTEGER :: i, j, totlen
393 
394 totlen = 0
395 DO i = 1, SIZE(fchar)
396  totlen = totlen + len_trim(fchar(i)) + 1
397 ENDDO
398 ALLOCATE(this%buffer(totlen), this%elem(SIZE(fchar) + 1))
399 totlen = 1
400 DO i = 1, SIZE(fchar)
401  this%elem(i) = c_loc(this%buffer(totlen))
402  DO j = 1, len_trim(fchar(i))
403  this%buffer(totlen) = fchar(i)(j:j)
404  totlen = totlen + 1
405  ENDDO
406  this%buffer(totlen) = char(0)
407  totlen = totlen + 1
408 ENDDO
409 this%elem(i) = c_null_ptr
410 
411 END FUNCTION c_ptr_ptr_new_from_fchar
412 
413 
417 FUNCTION c_ptr_ptr_getsize(this)
418 #ifdef DLL_EXPORT
419 !GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getsize
420 #endif
421 TYPE(c_ptr_ptr),INTENT(in) :: this
422 INTEGER :: c_ptr_ptr_getsize
423 
424 IF (ASSOCIATED(this%elem)) THEN
425  c_ptr_ptr_getsize = SIZE(this%elem) - 1
426 ELSE
427  c_ptr_ptr_getsize = 0
428 ENDIF
429 
430 END FUNCTION c_ptr_ptr_getsize
431 
440 FUNCTION c_ptr_ptr_getptr(this, n)
441 #ifdef DLL_EXPORT
442 !GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getptr
443 #endif
444 TYPE(c_ptr_ptr),INTENT(in) :: this
445 INTEGER,INTENT(in) :: n
446 TYPE(c_ptr) :: c_ptr_ptr_getptr
447 
448 c_ptr_ptr_getptr = c_null_ptr
449 IF (ASSOCIATED(this%elem)) THEN
450  IF (n > 0 .AND. n <= SIZE(this%elem)) THEN
451  c_ptr_ptr_getptr = this%elem(n)
452  ENDIF
453 ENDIF
454 
455 END FUNCTION c_ptr_ptr_getptr
456 
457 
461 FUNCTION c_ptr_ptr_getobject(this)
462 TYPE(c_ptr_ptr),INTENT(in) :: this
463 TYPE(c_ptr) :: c_ptr_ptr_getobject
464 
465 c_ptr_ptr_getobject = c_null_ptr
466 IF (ASSOCIATED(this%elem)) THEN
467  c_ptr_ptr_getobject = c_loc(this%elem(1))
468 ENDIF
469 
470 END FUNCTION c_ptr_ptr_getobject
471 
472 END MODULE fortranc
Fortran derived type for handling void**, char**, etc C objects (pointer to pointer or array of point...
Definition: fortranc.F90:133
Constructor for a c_ptr_ptr object.
Definition: fortranc.F90:176
Utility module for supporting Fortran 2003 C language interface module.
Definition: fortranc.F90:100
Equivalent of the strlen C function.
Definition: fortranc.F90:142
Convert a null-terminated C string into a Fortran CHARACTER variable of the proper length...
Definition: fortranc.F90:165