mirror of
https://github.com/saitohirga/WSJT-X.git
synced 2024-11-05 17:01:17 -05:00
22f66795a1
The azel.dat file is no longer written with future Doppler correction information designed for rigs that can't do CAT QSY commands while transmitting.
442 lines
16 KiB
Fortran
442 lines
16 KiB
Fortran
! FILE: c_interface_module.f90
|
|
! PURPOSE: Supplement ISO-C-Binding to provide type aliases and interfaces
|
|
! to common ISO-C string functions to aid working with strings.
|
|
! AUTHOR: Joseph M. Krahn
|
|
! STATUS: Still in development. Reasonably complete, but somewhat limited testing.
|
|
!
|
|
! The idea is to provide type aliases for all ISO-C types, so that the
|
|
! Fortran interface code more explicitly defines the actual C interface.
|
|
! This should be updated to support F2008 variable-length allocatable
|
|
! strings.
|
|
!
|
|
! Entity names all have the "C_" prefix, as with ISO-C-Binding, with a
|
|
! few exceptions.
|
|
!
|
|
! Sourced from: http://fortranwiki.org/fortran/show/c_interface_module
|
|
!
|
|
! One FORALL statement reverted to a DO loop to avoid a gfortran 4.9.2 ICE
|
|
!
|
|
module C_interface_module
|
|
use, intrinsic :: ISO_C_Binding, &
|
|
! C type aliases for pointer derived types:
|
|
C_ptr => C_ptr , &
|
|
C_char_ptr => C_ptr, &
|
|
C_const_char_ptr => C_ptr, &
|
|
C_void_ptr => C_ptr, &
|
|
C_const_void_ptr => C_ptr
|
|
|
|
implicit none
|
|
public
|
|
|
|
!----------------------------------------------------------------------------
|
|
! C type aliases for intrinsic type KIND parameters:
|
|
|
|
! NOTE: a C enum may not always be a standard C int
|
|
integer, parameter :: C_enum = C_int
|
|
|
|
! Defining off_t is difficult, because it may depend on "LARGEFILE" selection.
|
|
! integer, parameter :: C_off_t = ??
|
|
|
|
! C string terminator alais using the 3-letter ASCII name.
|
|
! The C_ prefix is not used because it is just an ASCII character.
|
|
character(len=1,kind=C_char), parameter :: NUL = C_NULL_char
|
|
|
|
! NOTE: In C, "char" is distinct from "signed char", unlike integers.
|
|
! The plain "char" type is specific for text/string values, whereas
|
|
! "signed char" should indicate 1-byte integer data.
|
|
!
|
|
! Most ISO-C systems have wide chars "wchar_t", but Fortran compilers
|
|
! have limited support for different character kinds. UTF encoding
|
|
! adds more complexity. This should be updated as Fortran compilers
|
|
! include support for more character types.
|
|
!
|
|
|
|
! Fortran does not (yet) support unsigned types.
|
|
integer, parameter :: &
|
|
C_unsigned = C_int, &
|
|
C_unsigned_short = C_short, &
|
|
C_unsigned_long = C_long, &
|
|
C_unsigned_long_long = C_long_long, &
|
|
C_unsigned_char = C_signed_char, &
|
|
C_ssize_t = C_size_t, &
|
|
C_uint8_t = C_int8_t, &
|
|
C_uint16_t = C_int16_t, &
|
|
C_uint32_t = C_int32_t, &
|
|
C_uint64_t = C_int64_t, &
|
|
C_uint_least8_t = C_int_least8_t, &
|
|
C_uint_least16_t = C_int_least16_t, &
|
|
C_uint_least32_t = C_int_least32_t, &
|
|
C_uint_least64_t = C_int_least64_t, &
|
|
C_uint_fast8_t = C_int_fast8_t, &
|
|
C_uint_fast16_t = C_int_fast16_t, &
|
|
C_uint_fast32_t = C_int_fast32_t, &
|
|
C_uint_fast64_t = C_int_fast64_t, &
|
|
C_uintmax_t = C_intmax_t
|
|
! Note: ptrdiff_t cannot be reliably defined from other types.
|
|
! When practical, it is larger than a pointer because it benefits
|
|
! from the full unsigned range in both positive and negative directions.
|
|
|
|
! Integer versions including 'int', where the 'int' is optional:
|
|
integer, parameter :: &
|
|
C_short_int = C_short, &
|
|
C_long_int = C_long, &
|
|
C_long_long_int = C_long_long, &
|
|
C_unsigned_int = C_unsigned, &
|
|
C_unsigned_short_int = C_short, &
|
|
C_unsigned_long_int = C_long, &
|
|
C_unsigned_long_long_int = C_long_long
|
|
|
|
interface C_F_string
|
|
module procedure C_F_string_ptr
|
|
module procedure C_F_string_chars
|
|
end interface C_F_string
|
|
|
|
interface F_C_string
|
|
module procedure F_C_string_ptr
|
|
module procedure F_C_string_chars
|
|
end interface F_C_string
|
|
|
|
!=======================================================================
|
|
! Some useful ISO C library string functions from <string.h>
|
|
! These are based on GCC header sections marked as NAMESPACE_STD
|
|
interface
|
|
|
|
! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed.
|
|
! extern void *memcpy (void *dest, const void *src, size_t n);
|
|
function C_memcpy(dest, src, n) result(result) bind(C,name="memcpy")
|
|
import C_void_ptr, C_size_t
|
|
type(C_void_ptr) :: result
|
|
type(C_void_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_void_ptr), value, intent(in) :: src ! target=intent(in)
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_memcpy
|
|
|
|
! Copy N bytes of SRC to DEST, guaranteeing correct behavior for overlapping strings.
|
|
!extern void *memmove (void *dest, const void *src, size_t n)
|
|
function C_memmove(dest, src, n) result(result) bind(C,name="memmove")
|
|
import C_void_ptr, C_size_t
|
|
type(C_void_ptr) :: result
|
|
type(C_void_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_void_ptr), value, intent(in) :: src
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_memmove
|
|
|
|
! Set N bytes of S to C.
|
|
!extern void *memset (void *s, int c, size_t n)
|
|
function C_memset(s, c, n) result(result) bind(C,name="memset")
|
|
import C_void_ptr, C_int, C_size_t
|
|
type(C_void_ptr) :: result
|
|
type(C_void_ptr), value, intent(in) :: s ! target=intent(out)
|
|
integer(C_int), value, intent(in) :: c
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_memset
|
|
|
|
! Compare N bytes of S1 and S2.
|
|
!extern int memcmp (const void *s1, const void *s2, size_t n)
|
|
pure function C_memcmp(s1, s2, n) result(result) bind(C,name="memcmp")
|
|
import C_int, C_void_ptr, C_size_t
|
|
integer(C_int) :: result
|
|
type(C_void_ptr), value, intent(in) :: s1
|
|
type(C_void_ptr), value, intent(in) :: s2
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_memcmp
|
|
|
|
! Search N bytes of S for C.
|
|
!extern void *memchr (const void *s, int c, size_t n)
|
|
pure function C_memchr(s, c, n) result(result) bind(C,name="memchr")
|
|
import C_void_ptr, C_int, C_size_t
|
|
type(C_void_ptr) :: result
|
|
type(C_void_ptr), value, intent(in) :: s
|
|
integer(C_int), value, intent(in) :: c
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_memchr
|
|
|
|
! Copy SRC to DEST.
|
|
!extern char *strcpy (char *dest, const char *src)
|
|
function C_strcpy(dest, src) result(result) bind(C,name="strcpy")
|
|
import C_char_ptr, C_size_t
|
|
type(C_char_ptr) :: result
|
|
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_char_ptr), value, intent(in) :: src
|
|
end function C_strcpy
|
|
|
|
! Copy no more than N characters of SRC to DEST.
|
|
!extern char *strncpy (char *dest, const char *src, size_t n)
|
|
function C_strncpy(dest, src, n) result(result) bind(C,name="strncpy")
|
|
import C_char_ptr, C_size_t
|
|
type(C_char_ptr) :: result
|
|
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_char_ptr), value, intent(in) :: src
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_strncpy
|
|
|
|
! Append SRC onto DEST.
|
|
!extern char *strcat (char *dest, const char *src)
|
|
function C_strcat(dest, src) result(result) bind(C,name="strcat")
|
|
import C_char_ptr, C_size_t
|
|
type(C_char_ptr) :: result
|
|
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_char_ptr), value, intent(in) :: src
|
|
end function C_strcat
|
|
|
|
! Append no more than N characters from SRC onto DEST.
|
|
!extern char *strncat (char *dest, const char *src, size_t n)
|
|
function C_strncat(dest, src, n) result(result) bind(C,name="strncat")
|
|
import C_char_ptr, C_size_t
|
|
type(C_char_ptr) :: result
|
|
type(C_char_ptr), value, intent(in) :: dest ! target=intent(out)
|
|
type(C_char_ptr), value, intent(in) :: src
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_strncat
|
|
|
|
! Compare S1 and S2.
|
|
!extern int strcmp (const char *s1, const char *s2)
|
|
pure function C_strcmp(s1, s2) result(result) bind(C,name="strcmp")
|
|
import C_int, C_char_ptr, C_size_t
|
|
integer(C_int) :: result
|
|
type(C_char_ptr), value, intent(in) :: s1
|
|
type(C_char_ptr), value, intent(in) :: s2
|
|
end function C_strcmp
|
|
|
|
! Compare N characters of S1 and S2.
|
|
!extern int strncmp (const char *s1, const char *s2, size_t n)
|
|
pure function C_strncmp(s1, s2, n) result(result) bind(C,name="strncmp")
|
|
import C_int, C_char_ptr, C_size_t
|
|
integer(C_int) :: result
|
|
type(C_char_ptr), value, intent(in) :: s1
|
|
type(C_char_ptr), value, intent(in) :: s2
|
|
integer(C_size_t), value, intent(in) :: n
|
|
end function C_strncmp
|
|
|
|
! Return the length of S.
|
|
!extern size_t strlen (const char *s)
|
|
pure function C_strlen(s) result(result) bind(C,name="strlen")
|
|
import C_char_ptr, C_size_t
|
|
integer(C_size_t) :: result
|
|
type(C_char_ptr), value, intent(in) :: s !character(len=*), intent(in)
|
|
end function C_strlen
|
|
|
|
end interface
|
|
|
|
! End of <string.h>
|
|
!=========================================================================
|
|
! Standard ISO-C malloc routines:
|
|
interface
|
|
|
|
! void *calloc(size_t nmemb, size_t size);
|
|
type(C_void_ptr) function C_calloc(nmemb, size) bind(C,name="calloc")
|
|
import C_void_ptr, C_size_t
|
|
integer(C_size_t), value, intent(in) :: nmemb, size
|
|
end function C_calloc
|
|
|
|
! void *malloc(size_t size);
|
|
type(C_void_ptr) function C_malloc(size) bind(C,name="malloc")
|
|
import C_void_ptr, C_size_t
|
|
integer(C_size_t), value, intent(in) :: size
|
|
end function C_malloc
|
|
|
|
! void free(void *ptr);
|
|
subroutine C_free(ptr) bind(C,name="free")
|
|
import C_void_ptr
|
|
type(C_void_ptr), value, intent(in) :: ptr
|
|
end subroutine C_free
|
|
|
|
! void *realloc(void *ptr, size_t size);
|
|
type(C_void_ptr) function C_realloc(ptr,size) bind(C,name="realloc")
|
|
import C_void_ptr, C_size_t
|
|
type(C_void_ptr), value, intent(in) :: ptr
|
|
integer(C_size_t), value, intent(in) :: size
|
|
end function C_realloc
|
|
|
|
end interface
|
|
|
|
interface assignment(=)
|
|
module procedure F_string_assign_C_string
|
|
end interface assignment(=)
|
|
|
|
!==========================================================================
|
|
|
|
contains
|
|
|
|
! HACK: For some reason, C_associated was not defined as pure.
|
|
pure logical function C_associated_pure(ptr) result(associated)
|
|
type(C_ptr), intent(in) :: ptr
|
|
integer(C_intptr_t) :: iptr
|
|
iptr = transfer(ptr,iptr)
|
|
associated = (iptr /= 0)
|
|
end function C_associated_pure
|
|
|
|
! Set a fixed-length Fortran string to the value of a C string.
|
|
subroutine F_string_assign_C_string(F_string, C_string)
|
|
character(len=*), intent(out) :: F_string
|
|
type(C_ptr), intent(in) :: C_string
|
|
character(len=1,kind=C_char), pointer :: p_chars(:)
|
|
integer :: i
|
|
if (.not. C_associated(C_string) ) then
|
|
F_string = ' '
|
|
else
|
|
call C_F_pointer(C_string,p_chars,[huge(0)])
|
|
i=1
|
|
do while(p_chars(i)/=NUL .and. i<=len(F_string))
|
|
F_string(i:i) = p_chars(i)
|
|
i=i+1
|
|
end do
|
|
if (i<len(F_string)) F_string(i:) = ' '
|
|
end if
|
|
end subroutine F_string_assign_C_string
|
|
|
|
! Copy a C string, passed by pointer, to a Fortran string.
|
|
! If the C pointer is NULL, the Fortran string is blanked.
|
|
! C_string must be NUL terminated, or at least as long as F_string.
|
|
! If C_string is longer, it is truncated. Otherwise, F_string is
|
|
! blank-padded at the end.
|
|
subroutine C_F_string_ptr(C_string, F_string)
|
|
type(C_ptr), intent(in) :: C_string
|
|
character(len=*), intent(out) :: F_string
|
|
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
|
integer :: i
|
|
if (.not. C_associated(C_string)) then
|
|
F_string = ' '
|
|
else
|
|
call C_F_pointer(C_string,p_chars,[huge(0)])
|
|
i=1
|
|
do while(p_chars(i)/=NUL .and. i<=len(F_string))
|
|
F_string(i:i) = p_chars(i)
|
|
i=i+1
|
|
end do
|
|
if (i<len(F_string)) F_string(i:) = ' '
|
|
end if
|
|
end subroutine C_F_string_ptr
|
|
|
|
! Copy a C string, passed as a char-array reference, to a Fortran string.
|
|
subroutine C_F_string_chars(C_string, F_string)
|
|
character(len=1,kind=C_char), intent(in) :: C_string(*)
|
|
character(len=*), intent(out) :: F_string
|
|
integer :: i
|
|
i=1
|
|
do while(C_string(i)/=NUL .and. i<=len(F_string))
|
|
F_string(i:i) = C_string(i)
|
|
i=i+1
|
|
end do
|
|
if (i<len(F_string)) F_string(i:) = ' '
|
|
end subroutine C_F_string_chars
|
|
|
|
! Copy a Fortran string to an allocated C string pointer.
|
|
! If the C pointer is NULL, no action is taken. (Maybe auto allocate via libc call?)
|
|
! If the length is not passed, the C string must be at least: len(F_string)+1
|
|
! If the length is passed and F_string is too long, it is truncated.
|
|
subroutine F_C_string_ptr(F_string, C_string, C_string_len)
|
|
character(len=*), intent(in) :: F_string
|
|
type(C_ptr), intent(in) :: C_string ! target = intent(out)
|
|
integer, intent(in), optional :: C_string_len ! Max string length,
|
|
! INCLUDING THE TERMINAL NUL
|
|
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
|
integer :: i, strlen
|
|
strlen = len(F_string)
|
|
if (present(C_string_len)) then
|
|
if (C_string_len <= 0) return
|
|
strlen = min(strlen,C_string_len)
|
|
end if
|
|
if (.not. C_associated(C_string)) then
|
|
return
|
|
end if
|
|
call C_F_pointer(C_string,p_chars,[strlen+1])
|
|
forall (i=1:strlen)
|
|
p_chars(i) = F_string(i:i)
|
|
end forall
|
|
p_chars(strlen+1) = NUL
|
|
end subroutine F_C_string_ptr
|
|
|
|
pure function C_strlen_safe(s) result(length)
|
|
integer(C_size_t) :: length
|
|
type(C_char_ptr), value, intent(in) :: s
|
|
if (.not. C_associated_pure(s)) then
|
|
length = 0
|
|
else
|
|
length = C_strlen(s)
|
|
end if
|
|
end function C_strlen_safe
|
|
|
|
function C_string_value(C_string) result(F_string)
|
|
type(C_ptr), intent(in) :: C_string
|
|
character(len=C_strlen_safe(C_string)) :: F_string
|
|
character(len=1,kind=C_char), dimension(:), pointer :: p_chars
|
|
integer :: i, length
|
|
length = len(F_string)
|
|
if (length/=0) then
|
|
call C_F_pointer(C_string,p_chars,[length])
|
|
forall (i=1:length)
|
|
F_string(i:i) = p_chars(i)
|
|
end forall
|
|
end if
|
|
end function C_string_value
|
|
|
|
! Copy a Fortran string to a C string passed by char-array reference.
|
|
! If the length is not passed, the C string must be at least: len(F_string)+1
|
|
! If the length is passed and F_string is too long, it is truncated.
|
|
subroutine F_C_string_chars(F_string, C_string, C_string_len)
|
|
character(len=*), intent(in) :: F_string
|
|
character(len=1,kind=C_char), dimension(*), intent(out) :: C_string
|
|
integer, intent(in), optional :: C_string_len ! Max string length,
|
|
! INCLUDING THE TERMINAL NUL
|
|
integer :: i, strlen
|
|
strlen = len(F_string)
|
|
if (present(C_string_len)) then
|
|
if (C_string_len <= 0) return
|
|
strlen = min(strlen,C_string_len)
|
|
end if
|
|
forall (i=1:strlen)
|
|
C_string(i) = F_string(i:i)
|
|
end forall
|
|
C_string(strlen+1) = NUL
|
|
end subroutine F_C_string_chars
|
|
|
|
! NOTE: Strings allocated here must be freed by the
|
|
! C library, such as via C_free() or C_string_free(),
|
|
type(C_ptr) function F_C_string_dup(F_string,length) result(C_string)
|
|
character(len=*), intent(in) :: F_string
|
|
integer, intent(in), optional :: length
|
|
character(len=1,kind=C_char), pointer :: C_string_ptr(:)
|
|
integer :: i
|
|
integer(C_size_t) :: strlen
|
|
if (present(length)) then
|
|
strlen = length
|
|
else
|
|
strlen = len(F_string)
|
|
end if
|
|
if (strlen <= 0) then
|
|
C_string = C_NULL_ptr
|
|
else
|
|
C_string = C_malloc(strlen+1)
|
|
if (C_associated(C_string)) then
|
|
call C_F_pointer(C_string,C_string_ptr,[strlen+1])
|
|
forall (i=1:strlen)
|
|
C_string_ptr(i) = F_string(i:i)
|
|
end forall
|
|
C_string_ptr(strlen+1) = NUL
|
|
end if
|
|
end if
|
|
end function F_C_string_dup
|
|
|
|
! NOTE: Strings allocated here must be freed by the
|
|
! C library, such as via C_free() or C_string_free(),
|
|
type(C_ptr) function C_string_alloc(length) result(C_string)
|
|
integer(C_size_t), intent(in) :: length
|
|
character(len=1,kind=C_char), pointer :: C_charptr
|
|
C_string = C_malloc(length+1)
|
|
if (C_associated(C_string)) then
|
|
call C_F_pointer(C_string,C_charptr)
|
|
C_charptr = NUL
|
|
end if
|
|
end function C_string_alloc
|
|
|
|
subroutine C_string_free(string)
|
|
type(C_ptr), intent(inout) :: string
|
|
if (C_associated(string)) then
|
|
call C_free(string)
|
|
string = C_NULL_ptr
|
|
end if
|
|
end subroutine C_string_free
|
|
|
|
end module C_interface_module
|