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 
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 
70 TYPE c_ptr_ptr
71  PRIVATE
72  TYPE(c_ptr),POINTER :: elem(:) => null()
73  CHARACTER(len=1),POINTER :: buffer(:) => null()
74 END TYPE c_ptr_ptr
75 
79 INTERFACE 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
85 END INTERFACE
86 
109 INTERFACE strtofchar
110  MODULE PROCEDURE strtofchar_char, strtofchar_chararr, strtofchar_intarr, &
111  strtofchar_ptr_2
112 END INTERFACE
113 
120 INTERFACE c_ptr_ptr_new
121  MODULE PROCEDURE c_ptr_ptr_new_from_c, c_ptr_ptr_new_from_fchar
122 END INTERFACE c_ptr_ptr_new
123 
124 INTERFACE ASSIGNMENT(=)
125  MODULE PROCEDURE strtofchararr_assign
126 END INTERFACE ASSIGNMENT(=)
127 
128 PRIVATE
129 PUBLIC strlen, strtofchar, fchartostr, fchartrimtostr, ASSIGNMENT(=)
130 PUBLIC c_ptr_ptr, c_ptr_ptr_new, c_ptr_ptr_getsize, c_ptr_ptr_getptr, c_ptr_ptr_getobject
131 
132 CONTAINS
133 
134 
135 PURE FUNCTION strlen_char(string) RESULT(strlen)
136 #ifdef DLL_EXPORT
137 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_char
138 #endif
139 CHARACTER(kind=c_char,len=*),INTENT(in) :: string
140 INTEGER :: strlen
141 
142 INTEGER :: i
143 
144 DO i = 1, len(string)
145  IF (string(i:i) == char(0)) EXIT
146 ENDDO
147 strlen = i - 1
148 
149 END FUNCTION strlen_char
150 
151 
152 PURE FUNCTION strlen_chararr(string) RESULT(strlen)
153 #ifdef DLL_EXPORT
154 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_chararr
155 #endif
156 CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
157 INTEGER :: strlen
158 
159 INTEGER :: i
160 
161 DO i = 1, SIZE(string)
162  IF (string(i) == char(0)) EXIT
163 ENDDO
164 strlen = i - 1
165 
166 END FUNCTION strlen_chararr
167 
168 
169 PURE FUNCTION strlen_intarr(string) RESULT(strlen)
170 #ifdef DLL_EXPORT
171 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_intarr
172 #endif
173 INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
174 INTEGER :: strlen
175 
176 INTEGER :: i
177 
178 DO i = 1, SIZE(string)
179  IF (string(i) == 0) EXIT
180 ENDDO
181 strlen = i - 1
182 
183 END FUNCTION strlen_intarr
184 
185 
186 FUNCTION strlen_ptr(string) RESULT(strlen)
187 #ifdef DLL_EXPORT
188 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_ptr
189 #endif
190 TYPE(c_ptr),INTENT(in) :: string
191 INTEGER :: strlen
192 
193 INTEGER(kind=c_signed_char),POINTER :: pstring(:)
194 INTEGER :: i
195 
196 IF (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
204 ELSE
205  strlen = 0
206 ENDIF
207 
208 END FUNCTION strlen_ptr
209 
210 
211 #ifdef WITH_VARYING_STRING
212 PURE FUNCTION strlen_var_str(string) RESULT(strlen)
213 #ifdef DLL_EXPORT
214 !GCC$ ATTRIBUTES DLLEXPORT :: strlen_var_str
215 #endif
216 TYPE(varying_string),INTENT(in) :: string
217 INTEGER :: strlen
218 
219 strlen = len(string)
220 
221 END FUNCTION strlen_var_str
222 #endif
223 
224 
225 FUNCTION strtofchar_char(string) RESULT(fchar)
226 #ifdef DLL_EXPORT
227 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_char
228 #endif
229 CHARACTER(kind=c_char,len=*),INTENT(in) :: string
230 CHARACTER(len=strlen(string)) :: fchar
231 
232 fchar(:) = string(1:len(fchar))
233 
234 END FUNCTION strtofchar_char
235 
236 
237 FUNCTION strtofchar_chararr(string) RESULT(fchar)
238 #ifdef DLL_EXPORT
239 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
240 #endif
241 CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
242 CHARACTER(len=strlen(string)) :: fchar
243 
244 INTEGER :: i
245 
246 DO i = 1, len(fchar)
247  fchar(i:i) = string(i)
248 ENDDO
249 
250 END FUNCTION strtofchar_chararr
251 
252 
253 FUNCTION strtofchar_intarr(string) RESULT(fchar)
254 #ifdef DLL_EXPORT
255 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_intarr
256 #endif
257 INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
258 CHARACTER(len=strlen(string)) :: fchar
259 
260 fchar(:) = transfer(string(1:len(fchar)), fchar)
261 
262 END 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 
286 FUNCTION strtofchar_ptr_2(string, fixlen) RESULT(fchar)
287 #ifdef DLL_EXPORT
288 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_ptr_2
289 #endif
290 TYPE(c_ptr),INTENT(in) :: string
291 INTEGER,INTENT(in) :: fixlen
292 CHARACTER(len=fixlen) :: fchar
293 
294 CHARACTER(len=fixlen),POINTER :: pfchar
295 INTEGER :: safelen
296 
297 safelen = min(strlen(string), fixlen)
298 
299 fchar = ''
300 IF (c_associated(string)) THEN
301  CALL c_f_pointer(string, pfchar)
302  fchar(1:safelen) = pfchar(1:safelen)
303 ENDIF
304 
305 END FUNCTION strtofchar_ptr_2
306 
307 
312 FUNCTION fchartostr(fchar) RESULT(string)
313 #ifdef DLL_EXPORT
314 !GCC$ ATTRIBUTES DLLEXPORT :: fchartostr
315 #endif
316 CHARACTER(len=*),INTENT(in) :: fchar
317 CHARACTER(kind=c_char,len=LEN(fchar)+1) :: string
318 
319 string = fchar//char(0)
320 
321 END FUNCTION fchartostr
322 
323 
329 FUNCTION fchartrimtostr(fchar) RESULT(string)
330 #ifdef DLL_EXPORT
331 !GCC$ ATTRIBUTES DLLEXPORT :: fchartrimtostr
332 #endif
333 CHARACTER(len=*),INTENT(in) :: fchar
334 CHARACTER(kind=c_char,len=LEN_TRIM(fchar)+1) :: string
335 
336 string = trim(fchar)//char(0)
337 
338 END FUNCTION fchartrimtostr
339 
340 
341 SUBROUTINE strtofchararr_assign(fchar, string)
342 #ifdef DLL_EXPORT
343 !GCC$ ATTRIBUTES DLLEXPORT :: strtofchararr_assign
344 #endif
345 CHARACTER(kind=c_char,len=1),ALLOCATABLE,INTENT(out) :: fchar(:)
346 TYPE(c_ptr),INTENT(in) :: string
347 
348 CHARACTER(kind=c_char),POINTER :: pstring(:)
349 INTEGER :: l
350 
351 l = strlen(string)
352 CALL c_f_pointer(string, pstring, (/l/))
353 ALLOCATE(fchar(l))
354 fchar(:) = pstring(:)
355 
356 END SUBROUTINE strtofchararr_assign
357 
358 
365 FUNCTION 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
369 TYPE(c_ptr),VALUE :: c_ptr_ptr_c
370 TYPE(c_ptr_ptr) :: this
371 
372 INTEGER :: i
373 TYPE(c_ptr),POINTER :: charp(:)
374 
375 IF (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
384 ENDIF
385 END FUNCTION c_ptr_ptr_new_from_c
386 
387 
394 FUNCTION c_ptr_ptr_new_from_fchar(fchar) RESULT(this)
395 CHARACTER(len=*) :: fchar(:)
396 TYPE(c_ptr_ptr) :: this
397 
398 INTEGER :: i, j, totlen
399 
400 totlen = 0
401 DO i = 1, SIZE(fchar)
402  totlen = totlen + len_trim(fchar(i)) + 1
403 ENDDO
404 ALLOCATE(this%buffer(totlen), this%elem(SIZE(fchar) + 1))
405 totlen = 1
406 DO 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
414 ENDDO
415 this%elem(i) = c_null_ptr
416 
417 END FUNCTION c_ptr_ptr_new_from_fchar
418 
419 
423 FUNCTION c_ptr_ptr_getsize(this)
424 #ifdef DLL_EXPORT
425 !GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getsize
426 #endif
427 TYPE(c_ptr_ptr),INTENT(in) :: this
428 INTEGER :: c_ptr_ptr_getsize
429 
430 IF (ASSOCIATED(this%elem)) THEN
431  c_ptr_ptr_getsize = SIZE(this%elem) - 1
432 ELSE
433  c_ptr_ptr_getsize = 0
434 ENDIF
435 
436 END FUNCTION c_ptr_ptr_getsize
437 
446 FUNCTION c_ptr_ptr_getptr(this, n)
447 #ifdef DLL_EXPORT
448 !GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getptr
449 #endif
450 TYPE(c_ptr_ptr),INTENT(in) :: this
451 INTEGER,INTENT(in) :: n
452 TYPE(c_ptr) :: c_ptr_ptr_getptr
453 
454 c_ptr_ptr_getptr = c_null_ptr
455 IF (ASSOCIATED(this%elem)) THEN
456  IF (n > 0 .AND. n <= SIZE(this%elem)) THEN
457  c_ptr_ptr_getptr = this%elem(n)
458  ENDIF
459 ENDIF
460 
461 END FUNCTION c_ptr_ptr_getptr
462 
463 
467 FUNCTION c_ptr_ptr_getobject(this)
468 TYPE(c_ptr_ptr),INTENT(in) :: this
469 TYPE(c_ptr) :: c_ptr_ptr_getobject
470 
471 c_ptr_ptr_getobject = c_null_ptr
472 IF (ASSOCIATED(this%elem)) THEN
473  c_ptr_ptr_getobject = c_loc(this%elem(1))
474 ENDIF
475 
476 END FUNCTION c_ptr_ptr_getobject
477 
478 END 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