fortranc.F90

!    Copyright 2011 Davide Cesari <dcesari69 at gmail dot com>
!
!    This file is part of FortranGIS.
!
!    FortranGIS is free software: you can redistribute it and/or modify
!    it under the terms of the GNU Lesser General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    FortranGIS is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Lesser General Public License for more details.
!
!    You should have received a copy of the GNU Lesser General Public
!    License along with FortranGIS.  If not, see
!    <http://www.gnu.org/licenses/>.
#include "config.h"

MODULE fortranc
use,INTRINSIC :: iso_c_binding
#ifdef WITH_VARYING_STRING
USE iso_varying_string
#endif
IMPLICIT NONE


TYPE c_ptr_ptr
  PRIVATE
  TYPE(c_ptr),POINTER :: elem(:) => null()
  CHARACTER(len=1),POINTER :: buffer(:) => null()
END TYPE c_ptr_ptr

INTERFACE strlen
  MODULE PROCEDURE strlen_char, strlen_chararr, strlen_intarr, &
   strlen_ptr
#ifdef WITH_VARYING_STRING
  MODULE PROCEDURE strlen_var_str
#endif
END INTERFACE

INTERFACE strtofchar
  MODULE PROCEDURE strtofchar_char, strtofchar_chararr, strtofchar_intarr, &
   strtofchar_ptr_2
END INTERFACE

INTERFACE c_ptr_ptr_new
  MODULE PROCEDURE c_ptr_ptr_new_from_c, c_ptr_ptr_new_from_fchar
END INTERFACE c_ptr_ptr_new

INTERFACE assignment(=)
  MODULE PROCEDURE strtofchararr_assign
END INTERFACE ASSIGNMENT(=)

PRIVATE
PUBLIC strlen, strtofchar, fchartostr, fchartrimtostr, assignment(=)
PUBLIC c_ptr_ptr, c_ptr_ptr_new, c_ptr_ptr_getsize, c_ptr_ptr_getptr, c_ptr_ptr_getobject

CONTAINS


PURE FUNCTION strlen_char(string) RESULT(strlen)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strlen_char
#endif
CHARACTER(kind=c_char,len=*),INTENT(in) :: string
INTEGER :: strlen

INTEGER :: i

DO i = 1, len(string)
  IF (string(i:i) == char(0)) EXIT
ENDDO
strlen = i - 1

END FUNCTION strlen_char


PURE FUNCTION strlen_chararr(string) RESULT(strlen)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strlen_chararr
#endif
CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
INTEGER :: strlen

INTEGER :: i

DO i = 1, SIZE(string)
  IF (string(i) == char(0)) EXIT
ENDDO
strlen = i - 1

END FUNCTION strlen_chararr


PURE FUNCTION strlen_intarr(string) RESULT(strlen)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strlen_intarr
#endif
INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
INTEGER :: strlen

INTEGER :: i

DO i = 1, SIZE(string)
  IF (string(i) == 0) EXIT
ENDDO
strlen = i - 1

END FUNCTION strlen_intarr


FUNCTION strlen_ptr(string) RESULT(strlen)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strlen_ptr
#endif
TYPE(c_ptr),INTENT(in) :: string
INTEGER :: strlen

INTEGER(kind=c_signed_char),POINTER :: pstring(:)
INTEGER :: i

IF (c_associated(string)) THEN ! conflicts with PURE
! null C pointer does not produce unassociated Fortran pointer with Intel
  CALL c_f_pointer(string, pstring, (/huge(i)/))
! IF (ASSOCIATED(pstring)) THEN
  DO i = 1, SIZE(pstring)
    IF (pstring(i) == 0) EXIT
  ENDDO
  strlen = i - 1
ELSE
  strlen = 0
ENDIF

END FUNCTION strlen_ptr


#ifdef WITH_VARYING_STRING
PURE FUNCTION strlen_var_str(string) RESULT(strlen)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strlen_var_str
#endif
TYPE(varying_string),INTENT(in) :: string
INTEGER :: strlen

strlen = len(string)

END FUNCTION strlen_var_str
#endif


FUNCTION strtofchar_char(string) RESULT(fchar)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_char
#endif
CHARACTER(kind=c_char,len=*),INTENT(in) :: string
CHARACTER(len=strlen(string)) :: fchar

fchar(:) = string(1:len(fchar))

END FUNCTION strtofchar_char


FUNCTION strtofchar_chararr(string) RESULT(fchar)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
#endif
CHARACTER(kind=c_char,len=1),INTENT(in) :: string(:)
CHARACTER(len=strlen(string)) :: fchar

INTEGER :: i

DO i = 1, len(fchar)
  fchar(i:i) = string(i)
ENDDO

END FUNCTION strtofchar_chararr


FUNCTION strtofchar_intarr(string) RESULT(fchar)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_intarr
#endif
INTEGER(kind=c_signed_char),INTENT(in) :: string(:)
CHARACTER(len=strlen(string)) :: fchar

fchar(:) = transfer(string(1:len(fchar)), fchar)

END FUNCTION strtofchar_intarr


! this unfortunately works only with gfortran where c_f_pointer is
! "erroneously" declared as PURE thus strlen_ptr can be PURE as well

!FUNCTION strtofchar_ptr(string) RESULT(fchar)
!TYPE(c_ptr),INTENT(in) :: string
!CHARACTER(len=strlen(string)) :: fchar
!
!CHARACTER(len=strlen(string)),POINTER :: pfchar
!
!IF (C_ASSOCIATED(string)) THEN
!  CALL c_f_pointer(string, pfchar)
!  fchar(:) = pfchar(:)
!!ELSE
!! silently return an empty string probably useless because
!! strlen is zero in this case (to be tested)
!!  fchar = ''
!ENDIF
!
!END FUNCTION strtofchar_ptr


FUNCTION strtofchar_ptr_2(string, fixlen) RESULT(fchar)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_ptr_2
#endif
TYPE(c_ptr),INTENT(in) :: string
INTEGER,INTENT(in) :: fixlen
CHARACTER(len=fixlen) :: fchar

CHARACTER(len=fixlen),POINTER :: pfchar
INTEGER :: safelen

safelen = min(strlen(string), fixlen)

fchar = ''
IF (c_associated(string)) THEN
  CALL c_f_pointer(string, pfchar)
  fchar(1:safelen) = pfchar(1:safelen)
ENDIF

END FUNCTION strtofchar_ptr_2


FUNCTION fchartostr(fchar) RESULT(string)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: fchartostr
#endif
CHARACTER(len=*),INTENT(in) :: fchar
CHARACTER(kind=c_char,len=LEN(fchar)+1) :: string

string = fchar//char(0)

END FUNCTION fchartostr


FUNCTION fchartrimtostr(fchar) RESULT(string)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: fchartrimtostr
#endif
CHARACTER(len=*),INTENT(in) :: fchar
CHARACTER(kind=c_char,len=LEN_TRIM(fchar)+1) :: string

string = trim(fchar)//char(0)

END FUNCTION fchartrimtostr


SUBROUTINE strtofchararr_assign(fchar, string)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: strtofchar_chararr
#endif
CHARACTER(kind=c_char,len=1),ALLOCATABLE,INTENT(out) :: fchar(:)
TYPE(c_ptr),INTENT(in) :: string

CHARACTER(kind=c_char),POINTER :: pstring(:)
INTEGER :: l

l = strlen(string)
CALL c_f_pointer(string, pstring, (/l/))
ALLOCATE(fchar(l))
fchar(:) = pstring(:)

END SUBROUTINE strtofchararr_assign


FUNCTION c_ptr_ptr_new_from_c(c_ptr_ptr_c) RESULT(this)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_new_from_c
#endif
TYPE(c_ptr),VALUE :: c_ptr_ptr_c
TYPE(c_ptr_ptr) :: this

INTEGER :: i
TYPE(c_ptr),POINTER :: charp(:)

IF (c_associated(c_ptr_ptr_c)) THEN
  ! HUGE() here is ugly, but we must set a finite size
  CALL c_f_pointer(c_ptr_ptr_c, charp, (/huge(1)/))
  DO i = 1, SIZE(charp)
    IF (.NOT.c_associated(charp(i))) THEN
      CALL c_f_pointer(c_ptr_ptr_c, this%elem, (/i/))
      RETURN
    ENDIF
  ENDDO
ENDIF
END FUNCTION c_ptr_ptr_new_from_c


FUNCTION c_ptr_ptr_new_from_fchar(fchar) RESULT(this)
CHARACTER(len=*) :: fchar(:)
TYPE(c_ptr_ptr) :: this

INTEGER :: i, j, totlen

totlen = 0
DO i = 1, SIZE(fchar)
  totlen = totlen + len_trim(fchar(i)) + 1
ENDDO
ALLOCATE(this%buffer(totlen), this%elem(SIZE(fchar) + 1))
totlen = 1
DO i = 1, SIZE(fchar)
  this%elem(i) = c_loc(this%buffer(totlen))
  DO j = 1, len_trim(fchar(i))
    this%buffer(totlen) = fchar(i)(j:j)
    totlen = totlen + 1
  ENDDO
  this%buffer(totlen) = char(0)
  totlen = totlen + 1
ENDDO
this%elem(i) = c_null_ptr

END FUNCTION c_ptr_ptr_new_from_fchar


FUNCTION c_ptr_ptr_getsize(this)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getsize
#endif
TYPE(c_ptr_ptr),INTENT(in) :: this
INTEGER :: c_ptr_ptr_getsize

IF (ASSOCIATED(this%elem)) THEN
  c_ptr_ptr_getsize = SIZE(this%elem) - 1
ELSE
  c_ptr_ptr_getsize = 0
ENDIF

END FUNCTION c_ptr_ptr_getsize

FUNCTION c_ptr_ptr_getptr(this, n)
#ifdef DLL_EXPORT
!GCC$ ATTRIBUTES DLLEXPORT :: c_ptr_ptr_getptr
#endif
TYPE(c_ptr_ptr),INTENT(in) :: this
INTEGER,INTENT(in) :: n
TYPE(c_ptr) :: c_ptr_ptr_getptr

c_ptr_ptr_getptr = c_null_ptr
IF (ASSOCIATED(this%elem)) THEN
  IF (n > 0 .AND. n <= SIZE(this%elem)) THEN
    c_ptr_ptr_getptr = this%elem(n)
  ENDIF
ENDIF

END FUNCTION c_ptr_ptr_getptr


FUNCTION c_ptr_ptr_getobject(this)
TYPE(c_ptr_ptr),INTENT(in) :: this
TYPE(c_ptr) :: c_ptr_ptr_getobject

c_ptr_ptr_getobject = c_null_ptr
IF (ASSOCIATED(this%elem)) THEN
  c_ptr_ptr_getobject = c_loc(this%elem(1))
ENDIF

END FUNCTION c_ptr_ptr_getobject

END MODULE fortranc