From 22f66795a1b32a07849479dced12e9847c2d5b1c Mon Sep 17 00:00:00 2001 From: Bill Somerville Date: Mon, 20 Jul 2020 15:15:55 +0100 Subject: [PATCH] Improved C/Fortran string interoperation, and fix azel.dat updates 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. --- CMakeLists.txt | 2 + lib/astrosub.f90 | 48 ++-- lib/c_interface_module.f90 | 441 +++++++++++++++++++++++++++++++++++++ lib/types.f90 | 10 + widgets/astro.cpp | 24 +- 5 files changed, 482 insertions(+), 43 deletions(-) create mode 100644 lib/c_interface_module.f90 create mode 100644 lib/types.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 80199358d..d2ed2459b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -358,6 +358,8 @@ endif (WIN32) set (wsjt_FSRCS # put module sources first in the hope that they get rebuilt before use + lib/types.f90 + lib/C_interface_module.f90 lib/shmem.f90 lib/crc.f90 lib/fftw3mod.f90 diff --git a/lib/astrosub.f90 b/lib/astrosub.f90 index 0670d66dc..5e7f473f0 100644 --- a/lib/astrosub.f90 +++ b/lib/astrosub.f90 @@ -1,5 +1,4 @@ module astro_module - use, intrinsic :: iso_c_binding, only : c_int, c_double, c_bool, c_char, c_ptr, c_size_t, c_f_pointer implicit none private @@ -7,50 +6,37 @@ module astro_module contains - subroutine astrosub(nyear,month,nday,uth8,freq8,mygrid_cp,mygrid_len, & - hisgrid_cp,hisgrid_len,AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8, & + subroutine astrosub(nyear,month,nday,uth8,freq8,mygrid_cp, & + hisgrid_cp,AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8, & ntsky,ndop,ndop00,RAMoon8,DecMoon8,Dgrd8,poloffset8,xnr8,techo8,width1, & - width2,bTx,AzElFileName_cp,AzElFileName_len,jpleph_cp,jpleph_len) & + width2,bTx,AzElFileName_cp,jpleph_file_name_cp) & bind (C, name="astrosub") - integer, parameter :: dp = selected_real_kind(15, 50) + use :: types, only: dp + use :: C_interface_module, only: C_int, C_double, C_bool, C_ptr, C_string_value, assignment(=) - integer(c_int), intent(in), value :: nyear, month, nday - real(c_double), intent(in), value :: uth8, freq8 - real(c_double), intent(out) :: AzSun8, ElSun8, AzMoon8, ElMoon8, AzMoonB8, & + integer(C_int), intent(in), value :: nyear, month, nday + real(C_double), intent(in), value :: uth8, freq8 + real(C_double), intent(out) :: AzSun8, ElSun8, AzMoon8, ElMoon8, AzMoonB8, & ElMoonB8, Ramoon8, DecMoon8, Dgrd8, poloffset8, xnr8, techo8, width1, & width2 - integer(c_int), intent(out) :: ntsky, ndop, ndop00 - logical(c_bool), intent(in), value :: bTx - type(c_ptr), intent(in), value :: mygrid_cp, hisgrid_cp, AzElFileName_cp, jpleph_cp - integer(c_size_t), intent(in), value :: mygrid_len, hisgrid_len, AzElFileName_len, jpleph_len + integer(C_int), intent(out) :: ntsky, ndop, ndop00 + logical(C_bool), intent(in), value :: bTx + type(C_ptr), value, intent(in) :: mygrid_cp, hisgrid_cp, AzElFileName_cp, & + jpleph_file_name_cp character(len=6) :: mygrid, hisgrid - character(kind=c_char, len=:), allocatable :: AzElFileName + character(len=:), allocatable :: AzElFileName character(len=1) :: c1 integer :: ih, im, imin, is, isec, nfreq, nRx real(dp) :: AzAux, ElAux, dbMoon8, dfdt, dfdt0, doppler, doppler00, HA8, sd8, xlst8 character*256 jpleph_file_name common/jplcom/jpleph_file_name - block - character(kind=c_char, len=mygrid_len), pointer :: mygrid_fp - character(kind=c_char, len=hisgrid_len), pointer :: hisgrid_fp - character(kind=c_char, len=AzElFileName_len), pointer :: AzElFileName_fp - character(kind=c_char, len=jpleph_len), pointer :: jpleph_fp - call c_f_pointer(cptr=mygrid_cp, fptr=mygrid_fp) - mygrid = mygrid_fp - mygrid_fp => null() - call c_f_pointer(cptr=hisgrid_cp, fptr=hisgrid_fp) - hisgrid = hisgrid_fp - hisgrid_fp => null() - call c_f_pointer(cptr=AzElFileName_cp, fptr=AzElFileName_fp) - AzElFileName = AzElFileName_fp - AzElFileName_fp => null() - call c_f_pointer(cptr=jpleph_cp, fptr=jpleph_fp) - jpleph_file_name = jpleph_fp - jpleph_fp => null() - end block + mygrid = mygrid_cp + hisgrid = hisgrid_cp + AzElFileName = C_string_value (AzElFileName_cp) + jpleph_file_name = jpleph_file_name_cp call astro0(nyear,month,nday,uth8,freq8,mygrid,hisgrid, & AzSun8,ElSun8,AzMoon8,ElMoon8,AzMoonB8,ElMoonB8,ntsky,ndop,ndop00, & diff --git a/lib/c_interface_module.f90 b/lib/c_interface_module.f90 new file mode 100644 index 000000000..47fee9de4 --- /dev/null +++ b/lib/c_interface_module.f90 @@ -0,0 +1,441 @@ +! 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 + ! 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 + !========================================================================= + ! 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 (idata_dir ().absoluteFilePath ("JPLEPH"); astrosub(nyear, month, nday, uth, static_cast (freq_moon), - mygrid.toLatin1 ().constData (), mygrid.size (), - hisgrid.toLatin1().constData(), hisgrid.size (), + mygrid.toLatin1 ().data (), + hisgrid.toLatin1().data(), &azsun, &elsun, &azmoon, &elmoon, &azmoondx, &elmoondx, &ntsky, &m_dop, &m_dop00, &ramoon, &decmoon, &dgrd, &poloffset, &xnr, &techo, &width1, &width2, bTx, - AzElFileName.toLatin1().constData(), AzElFileName.size (), - jpleph.toLatin1().constData(), jpleph.size ()); + AzElFileName.toLatin1().data(), + jpleph.toLatin1().data()); if(!hisgrid.size ()) { azmoondx=0.0; @@ -224,14 +224,14 @@ auto Astro::astroUpdate(QDateTime const& t, QString const& mygrid, QString const double sec {target_date_time.time().second() + 0.001*target_date_time.time().msec()}; double uth {nhr + nmin/60.0 + sec/3600.0}; astrosub(nyear, month, nday, uth, static_cast (freq_moon), - mygrid.toLatin1 ().constData (), mygrid.size (), - hisgrid.toLatin1().constData(), hisgrid.size (), + mygrid.toLatin1 ().data (), + hisgrid.toLatin1().data(), &azsun, &elsun, &azmoon, &elmoon, &azmoondx, &elmoondx, &ntsky, &m_dop, &m_dop00, &ramoon, &decmoon, &dgrd, &poloffset, &xnr, &techo, &width1, &width2, bTx, - AzElFileName.toLatin1().constData(), AzElFileName.size (), - jpleph.toLatin1().constData(), jpleph.size ()); + nullptr, // don't overwrite azel.dat + jpleph.toLatin1().data()); FrequencyDelta offset {0}; switch (m_DopplerMethod) {