commit bce396d541d65029e2897e59c6e0baeed090e340
Author: Sandra Loosemore <sandra@codesourcery.com>
Date: Wed Aug 18 07:22:03 2021 -0700
libgfortran: Further fixes for GFC/CFI descriptor conversions.
This patch is for:
PR100907 - Bind(c): failure handling wide character
PR100911 - Bind(c): failure handling C_PTR
PR100914 - Bind(c): errors handling complex
PR100915 - Bind(c): failure handling C_FUNPTR
PR100917 - Bind(c): errors handling long double real
All of these problems are related to the GFC descriptors constructed
by the Fortran front end containing ambigous or incomplete
information. This patch does not attempt to change the GFC data
structure or the front end, and only makes the runtime interpret it in
more reasonable ways. It's not a complete fix for any of the listed
issues.
The Fortran front end does not distinguish between C_PTR and
C_FUNPTR, mapping both onto BT_VOID. That is what this patch does also.
The other bugs are related to GFC descriptors only containing elem_len
and not kind. For complex types, the elem_len needs to be divided by
2 and then mapped onto a real kind. On x86 targets, the kind
corresponding to C long double is different than its elem_len; since
we cannot accurately disambiguate between a 16-byte kind 10 long
double from __float128, this patch arbitrarily prefers to interpret that as
the standard long double type rather than the GNU extension.
Similarly, for character types, the GFC descriptor cannot distinguish
between character(kind=c_char, len=4) and character(kind=ucs4, len=1).
But since the front end currently rejects anything other than len=1
(PR92482) this patch uses the latter interpretation.
2021-08-18 Sandra Loosemore <sandra@codesourcery.com>
José Rui Faustino de Sousa <jrfsousa@gmail.com>
gcc/testsuite/
PR fortran/100911
PR fortran/100915
PR fortran/100916
* gfortran.dg/PR100911.c: New file.
* gfortran.dg/PR100911.f90: New file.
* gfortran.dg/PR100914.c: New file.
* gfortran.dg/PR100914.f90: New file.
* gfortran.dg/PR100915.c: New file.
* gfortran.dg/PR100915.f90: New file.
libgfortran/
PR fortran/100907
PR fortran/100911
PR fortran/100914
PR fortran/100915
PR fortran/100917
* ISO_Fortran_binding.h (CFI_type_cfunptr): Make equivalent to
CFI_type_cptr.
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Fix
handling of CFI_type_cptr and CFI_type_cfunptr. Additional error
checking and code cleanup.
(gfc_desc_to_cfi_desc): Likewise. Also correct kind mapping
for character, complex, and long double types.
new file mode 100644
@@ -0,0 +1,82 @@
+/* Test the fix for PR100911 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+
+#define _CFI_type_mask 0xFF
+#define _CFI_type_kind_shift 8
+
+#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
+#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
+
+#define _CFI_encode_type(TYPE, KIND) (int16_t)\
+((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
+ | ((TYPE) & CFI_type_mask))
+
+#define N 11
+#define M 7
+
+#define CFI_type_Cptr CFI_type_cptr
+
+typedef int* c_ptr;
+
+bool c_vrfy_cptr (const CFI_cdesc_t *restrict);
+
+void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
+
+bool
+c_vrfy_cptr (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_ptr *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_ptr);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_ptr*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((**ip) != (int)(i+1))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_ptr*)CFI_address(auxp, &i);
+ if ((**ip) != (int)(i-lb+1))
+ return false;
+ }
+ return true;
+}
+
+void
+check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
+{
+ signed char ityp, iknd;
+
+ assert (auxp);
+ assert (auxp->elem_len==elem_len*nelem);
+ assert (auxp->rank==1);
+ assert (auxp->dim[0].sm>0);
+ assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
+ /* */
+ assert (auxp->type==type);
+ ityp = _CFI_decode_type(auxp->type);
+ assert (ityp == CFI_type_cptr);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_cptr (auxp));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,282 @@
+! { dg-do run }
+! { dg-additional-sources PR100911.c }
+!
+! Test the fix for PR100911
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_cptr
+
+ public :: &
+ check_tk_as, &
+ check_tk_ar
+
+ public :: &
+ cfi_encode_type
+
+ integer, parameter :: CFI_type_t = c_int16_t
+
+ integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
+ integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
+
+ ! Intrinsic types. Their kind number defines their storage size. */
+ integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7
+
+ interface
+ subroutine check_tk_as(a, t, k, e, n) &
+ bind(c, name="check_tk")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(:)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_tk_as
+ subroutine check_tk_ar(a, t, k, e, n) &
+ bind(c, name="check_tk")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(..)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_tk_ar
+ end interface
+
+contains
+
+ elemental function cfi_encode_type(type, kind) result(itype)
+ integer(kind=c_signed_char), intent(in) :: type
+ integer(kind=c_signed_char), intent(in) :: kind
+
+ integer(kind=c_int16_t) :: itype, ikind
+
+ itype = int(type, kind=c_int16_t)
+ itype = iand(itype, CFI_type_mask)
+ ikind = int(kind, kind=c_int16_t)
+ ikind = iand(ikind, CFI_type_mask)
+ ikind = shiftl(ikind, CFI_type_kind_shift)
+ itype = ior(ikind, itype)
+ return
+ end function cfi_encode_type
+
+end module isof_m
+
+module iso_check_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t, c_size_t
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_int, c_ptr, c_loc, c_associated
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_ptr
+
+ use :: isof_m, only: &
+ CFI_type_cptr
+
+ use :: isof_m, only: &
+ check_tk_as, &
+ check_tk_ar
+
+ use :: isof_m, only: &
+ cfi_encode_type
+
+ implicit none
+
+ integer :: i
+ integer(kind=c_size_t), parameter :: b = 8
+ integer, parameter :: n = 11
+
+ type, bind(c) :: c_foo_t
+ integer(kind=c_int) :: a
+ end type c_foo_t
+
+ type(c_foo_t), parameter :: ref_c_foo_t(*) = [(c_foo_t(a=i), i=1,n)]
+
+ type(c_foo_t), protected, target :: target_c_foo_t(n)
+
+
+contains
+
+ subroutine check_c_ptr()
+ type(c_ptr) :: p(n)
+ integer :: i
+ !
+ target_c_foo_t = ref_c_foo_t
+ p = [(c_loc(target_c_foo_t(i)), i=1,n)]
+ call f_check_c_ptr_as(p)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 1
+ do i = 1, n
+ if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 2
+ end do
+ target_c_foo_t = ref_c_foo_t
+ p = [(c_loc(target_c_foo_t(i)), i=1,n)]
+ call c_check_c_ptr_as(p)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 3
+ do i = 1, n
+ if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 4
+ end do
+ target_c_foo_t = ref_c_foo_t
+ p = [(c_loc(target_c_foo_t(i)), i=1,n)]
+ call f_check_c_ptr_ar(p)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 5
+ do i = 1, n
+ if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 6
+ end do
+ target_c_foo_t = ref_c_foo_t
+ p = [(c_loc(target_c_foo_t(i)), i=1,n)]
+ call c_check_c_ptr_ar(p)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 7
+ do i = 1, n
+ if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 8
+ end do
+ return
+ end subroutine check_c_ptr
+
+ subroutine f_check_c_ptr_as(a)
+ type(c_ptr), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 9
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 10
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 11
+ end do
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 12
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 13
+ end do
+ return
+ end subroutine f_check_c_ptr_as
+
+ subroutine c_check_c_ptr_as(a) bind(c)
+ type(c_ptr), intent(in) :: a(:)
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 14
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 15
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 16
+ end do
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 17
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 18
+ end do
+ return
+ end subroutine c_check_c_ptr_as
+
+ subroutine f_check_c_ptr_ar(a)
+ type(c_ptr), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 19
+ select rank(a)
+ rank(1)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 20
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 21
+ end do
+ rank default
+ stop 22
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 23
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 24
+ end do
+ rank default
+ stop 25
+ end select
+ return
+ end subroutine f_check_c_ptr_ar
+
+ subroutine c_check_c_ptr_ar(a) bind(c)
+ type(c_ptr), intent(in) :: a(..)
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 26
+ select rank(a)
+ rank(1)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 27
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 28
+ end do
+ rank default
+ stop 29
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 30
+ do i = 1, n
+ if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 31
+ end do
+ rank default
+ stop 32
+ end select
+ return
+ end subroutine c_check_c_ptr_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_ptr
+
+ implicit none
+
+ call check_c_ptr()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
new file mode 100644
@@ -0,0 +1,226 @@
+/* Test the fix for PR100914 */
+
+#include <assert.h>
+#include <complex.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <math.h>
+#include <quadmath.h>
+
+#include <ISO_Fortran_binding.h>
+
+#define _CFI_type_mask 0xFF
+#define _CFI_type_kind_shift 8
+
+#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
+#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
+
+#define _CFI_encode_type(TYPE, KIND) (int16_t)\
+((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
+ | ((TYPE) & CFI_type_mask))
+
+#undef CMPLXF
+#define CMPLXF(x, y) ((float complex)((float)(x) + I * (float)(y)))
+
+#undef CMPLX
+#define CMPLX(x, y) ((double complex)((double)(x) + (double complex)I * (double)(y)))
+
+#undef CMPLXL
+#define CMPLXL(x, y) ((long double complex)((long double)(x) + (long double complex)I * (long double)(y)))
+
+#undef CMPLX
+#define CMPLX(x, y) ((__complex128 )((double)(x) + (double complex)I * (double)(y)))
+
+#define N 11
+#define M 7
+
+typedef float _Complex c_float_complex;
+typedef double _Complex c_double_complex;
+typedef long double _Complex c_long_double_complex;
+typedef __complex128 c_float128_complex;
+
+bool c_vrfy_c_float_complex (const CFI_cdesc_t *restrict);
+
+bool c_vrfy_c_double_complex (const CFI_cdesc_t *restrict);
+
+bool c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict);
+
+bool c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict);
+
+bool c_vrfy_complex (const CFI_cdesc_t *restrict);
+
+bool c_vrfy_desc (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
+
+void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
+
+
+
+bool
+c_vrfy_c_float_complex (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_float_complex *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_float_complex);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_float_complex*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((cabsf (*ip-(c_float_complex)(CMPLXF((i+1), (2*(i+1)))))>(float)0.0))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_float_complex*)CFI_address(auxp, &i);
+ if ((cabsf (*ip-(c_float_complex)(CMPLXF((i-lb+1), (2*(i-lb+1)))))>(float)0.0))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_c_double_complex (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_double_complex *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_double_complex);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_double_complex*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((cabs (*ip-(c_double_complex)(CMPLX((i+1), (2*(i+1)))))>(double)0.0))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_double_complex*)CFI_address(auxp, &i);
+ if ((cabs (*ip-(c_double_complex)(CMPLX((i-lb+1), (2*(i-lb+1)))))>(double)0.0))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_long_double_complex *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_long_double_complex);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_long_double_complex*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i+1), (2*(i+1)))))>(long double)0.0))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_long_double_complex*)CFI_address(auxp, &i);
+ if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i-lb+1), (2*(i-lb+1)))))>(long double)0.0))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_float128_complex *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_float128_complex);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_float128_complex*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i+1), (2*(i+1))))))>(double)0.0))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_float128_complex*)CFI_address(auxp, &i);
+ if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i-lb+1), (2*(i-lb+1))))))>(double)0.0))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_complex (const CFI_cdesc_t *restrict auxp)
+{
+ signed char type, kind;
+
+ assert (auxp);
+ type = _CFI_decode_type(auxp->type);
+ kind = _CFI_decode_kind(auxp->type);
+ assert (type == CFI_type_Complex);
+ switch (kind)
+ {
+ case 4:
+ return c_vrfy_c_float_complex (auxp);
+ break;
+ case 8:
+ return c_vrfy_c_double_complex (auxp);
+ break;
+ case 10:
+ return c_vrfy_c_long_double_complex (auxp);
+ break;
+ case 16:
+ return c_vrfy_c_float128_complex (auxp);
+ break;
+ default:
+ assert (false);
+ }
+ return true;
+}
+
+void
+check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
+{
+ signed char ityp, iknd;
+
+ assert (auxp);
+ assert (auxp->elem_len==elem_len*nelem);
+ assert (auxp->rank==1);
+ assert (auxp->dim[0].sm>0);
+ assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
+ /* */
+ assert (auxp->type==type);
+ ityp = _CFI_decode_type(auxp->type);
+ assert (ityp == CFI_type_Complex);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_complex (auxp));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,651 @@
+! Fails on x86 targets where sizeof(long double) == 16.
+! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } }
+! { dg-additional-sources PR100914.c }
+! { dg-require-effective-target fortran_real_c_float128 }
+!
+! Test the fix for PR100914
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_Complex, &
+ CFI_type_float_Complex, &
+ CFI_type_double_Complex, &
+ CFI_type_long_double_Complex, &
+ CFI_type_float128_Complex
+
+ public :: &
+ check_tk_as, &
+ check_tk_ar
+
+
+ public :: &
+ cfi_encode_type
+
+ integer, parameter :: CFI_type_t = c_int16_t
+
+ integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
+ integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
+
+ ! Intrinsic types. Their kind number defines their storage size. */
+ integer(kind=c_signed_char), parameter :: CFI_type_Complex = 4
+
+ ! C-Fortran Interoperability types.
+ integer(kind=cfi_type_t), parameter :: CFI_type_float_Complex = &
+ ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift))
+ integer(kind=cfi_type_t), parameter :: CFI_type_double_Complex = &
+ ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(8_c_int16_t, CFI_type_kind_shift))
+ integer(kind=cfi_type_t), parameter :: CFI_type_long_double_Complex = &
+ ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(10_c_int16_t, CFI_type_kind_shift))
+ integer(kind=cfi_type_t), parameter :: CFI_type_float128_Complex = &
+ ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(16_c_int16_t, CFI_type_kind_shift))
+
+ interface
+ subroutine check_tk_as(a, t, k, e, n) &
+ bind(c, name="check_tk")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(:)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_tk_as
+ subroutine check_tk_ar(a, t, k, e, n) &
+ bind(c, name="check_tk")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(..)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_tk_ar
+ end interface
+
+contains
+
+ elemental function cfi_encode_type(type, kind) result(itype)
+ integer(kind=c_signed_char), intent(in) :: type
+ integer(kind=c_signed_char), intent(in) :: kind
+
+ integer(kind=c_int16_t) :: itype, ikind
+
+ itype = int(type, kind=c_int16_t)
+ itype = iand(itype, CFI_type_mask)
+ ikind = int(kind, kind=c_int16_t)
+ ikind = iand(ikind, CFI_type_mask)
+ ikind = shiftl(ikind, CFI_type_kind_shift)
+ itype = ior(ikind, itype)
+ return
+ end function cfi_encode_type
+
+end module isof_m
+
+module iso_check_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t, c_size_t
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_float_complex, &
+ c_double_complex, &
+ c_long_double_complex, &
+ c_float128_complex
+
+ use :: isof_m, only: &
+ CFI_type_Complex
+
+ use :: isof_m, only: &
+ CFI_type_float_Complex, &
+ CFI_type_double_Complex, &
+ CFI_type_long_double_Complex, &
+ CFI_type_float128_Complex
+
+ use :: isof_m, only: &
+ check_tk_as, &
+ check_tk_ar
+
+ use :: isof_m, only: &
+ cfi_encode_type
+
+ implicit none
+
+ private
+
+ public :: &
+ check_c_float_complex, &
+ check_c_double_complex, &
+ check_c_long_double_complex, &
+ check_c_float128_complex
+
+ integer :: i
+ integer(kind=c_size_t), parameter :: b = 8
+ integer, parameter :: n = 11
+
+ complex(kind=c_float_complex), parameter :: ref_c_float_complex(*) = &
+ [(cmplx(i, 2*i, kind=c_float_complex), i=1,n)]
+ complex(kind=c_double_complex), parameter :: ref_c_double_complex(*) = &
+ [(cmplx(i, 2*i, kind=c_double_complex), i=1,n)]
+ complex(kind=c_long_double_complex), parameter :: ref_c_long_double_complex(*) = &
+ [(cmplx(i, 2*i, kind=c_long_double_complex), i=1,n)]
+ complex(kind=c_float128_complex), parameter :: ref_c_float128_complex(*) = &
+ [(cmplx(i, 2*i, kind=c_float128_complex), i=1,n)]
+
+contains
+
+ ! CFI_type_float_complex
+ subroutine check_c_float_complex()
+ complex(kind=c_float_complex) :: a(n)
+ !
+ if (c_float_complex/=4) stop 1
+ a = ref_c_float_complex
+ call f_check_c_float_complex_as(a)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 2
+ a = ref_c_float_complex
+ call c_check_c_float_complex_as(a)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 3
+ a = ref_c_float_complex
+ call f_check_c_float_complex_ar(a)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 4
+ a = ref_c_float_complex
+ call c_check_c_float_complex_ar(a)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 5
+ return
+ end subroutine check_c_float_complex
+
+ subroutine f_check_c_float_complex_as(a)
+ complex(kind=c_float_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 6
+ if(k/=4_c_signed_char) stop 7
+ if(int(k, kind=c_size_t)/=(e/2)) stop 8
+ if(t/=CFI_type_float_complex) stop 9
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 10
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 11
+ return
+ end subroutine f_check_c_float_complex_as
+
+ subroutine c_check_c_float_complex_as(a) bind(c)
+ complex(kind=c_float_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 12
+ if(k/=4_c_signed_char) stop 13
+ if(int(k, kind=c_size_t)/=(e/2)) stop 14
+ if(t/=CFI_type_float_complex) stop 15
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 16
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 17
+ return
+ end subroutine c_check_c_float_complex_as
+
+ subroutine f_check_c_float_complex_ar(a)
+ complex(kind=c_float_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 18
+ if(k/=4_c_signed_char) stop 19
+ if(int(k, kind=c_size_t)/=(e/2)) stop 20
+ if(t/=CFI_type_float_complex) stop 21
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 22
+ rank default
+ stop 23
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 24
+ rank default
+ stop 25
+ end select
+ return
+ end subroutine f_check_c_float_complex_ar
+
+ subroutine c_check_c_float_complex_ar(a) bind(c)
+ complex(kind=c_float_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 26
+ if(k/=4_c_signed_char) stop 27
+ if(int(k, kind=c_size_t)/=(e/2)) stop 28
+ if(t/=CFI_type_float_complex) stop 29
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 30
+ rank default
+ stop 31
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 32
+ rank default
+ stop 33
+ end select
+ return
+ end subroutine c_check_c_float_complex_ar
+
+ ! CFI_type_double_complex
+ subroutine check_c_double_complex()
+ complex(kind=c_double_complex) :: a(n)
+ !
+ if (c_double_complex/=8) stop 34
+ a = ref_c_double_complex
+ call f_check_c_double_complex_as(a)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 35
+ a = ref_c_double_complex
+ call c_check_c_double_complex_as(a)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 36
+ a = ref_c_double_complex
+ call f_check_c_double_complex_ar(a)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 37
+ a = ref_c_double_complex
+ call c_check_c_double_complex_ar(a)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 38
+ return
+ end subroutine check_c_double_complex
+
+ subroutine f_check_c_double_complex_as(a)
+ complex(kind=c_double_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 39
+ if(k/=8_c_signed_char) stop 40
+ if(int(k, kind=c_size_t)/=(e/2)) stop 41
+ if(t/=CFI_type_double_complex) stop 42
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 43
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 44
+ return
+ end subroutine f_check_c_double_complex_as
+
+ subroutine c_check_c_double_complex_as(a) bind(c)
+ complex(kind=c_double_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 45
+ if(k/=8_c_signed_char) stop 46
+ if(int(k, kind=c_size_t)/=(e/2)) stop 47
+ if(t/=CFI_type_double_complex) stop 48
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 49
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 50
+ return
+ end subroutine c_check_c_double_complex_as
+
+ subroutine f_check_c_double_complex_ar(a)
+ complex(kind=c_double_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 51
+ if(k/=8_c_signed_char) stop 52
+ if(int(k, kind=c_size_t)/=(e/2)) stop 53
+ if(t/=CFI_type_double_complex) stop 54
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 55
+ rank default
+ stop 56
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 57
+ rank default
+ stop 58
+ end select
+ return
+ end subroutine f_check_c_double_complex_ar
+
+ subroutine c_check_c_double_complex_ar(a) bind(c)
+ complex(kind=c_double_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 59
+ if(k/=8_c_signed_char) stop 60
+ if(int(k, kind=c_size_t)/=(e/2)) stop 61
+ if(t/=CFI_type_double_complex) stop 62
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 63
+ rank default
+ stop 64
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 65
+ rank default
+ stop 66
+ end select
+ return
+ end subroutine c_check_c_double_complex_ar
+
+ ! CFI_type_long_double_complex
+ subroutine check_c_long_double_complex()
+ complex(kind=c_long_double_complex) :: a(n)
+ !
+ if (c_long_double_complex/=10) stop 67
+ a = ref_c_long_double_complex
+ call f_check_c_long_double_complex_as(a)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 68
+ a = ref_c_long_double_complex
+ call c_check_c_long_double_complex_as(a)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 69
+ a = ref_c_long_double_complex
+ call f_check_c_long_double_complex_ar(a)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 70
+ a = ref_c_long_double_complex
+ call c_check_c_long_double_complex_ar(a)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 71
+ return
+ end subroutine check_c_long_double_complex
+
+ subroutine f_check_c_long_double_complex_as(a)
+ complex(kind=c_long_double_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 72
+ if(k/=10_c_signed_char) stop 73
+ if(e/=32) stop 74
+ if(t/=CFI_type_long_double_complex) stop 75
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 76
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 77
+ return
+ end subroutine f_check_c_long_double_complex_as
+
+ subroutine c_check_c_long_double_complex_as(a) bind(c)
+ complex(kind=c_long_double_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 78
+ if(k/=10_c_signed_char) stop 79
+ if(e/=32) stop 80
+ if(t/=CFI_type_long_double_complex) stop 81
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 82
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 83
+ return
+ end subroutine c_check_c_long_double_complex_as
+
+ subroutine f_check_c_long_double_complex_ar(a)
+ complex(kind=c_long_double_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 84
+ if(k/=10_c_signed_char) stop 85
+ if(e/=32) stop 86
+ if(t/=CFI_type_long_double_complex) stop 87
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 88
+ rank default
+ stop 89
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 90
+ rank default
+ stop 91
+ end select
+ return
+ end subroutine f_check_c_long_double_complex_ar
+
+ subroutine c_check_c_long_double_complex_ar(a) bind(c)
+ complex(kind=c_long_double_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 92
+ if(k/=10_c_signed_char) stop 93
+ if(e/=32) stop 94
+ if(t/=CFI_type_long_double_complex) stop 95
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 96
+ rank default
+ stop 97
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 98
+ rank default
+ stop 99
+ end select
+ return
+ end subroutine c_check_c_long_double_complex_ar
+
+ ! CFI_type_float128_complex
+ subroutine check_c_float128_complex()
+ complex(kind=c_float128_complex) :: a(n)
+ !
+ if (c_float128_complex/=16) stop 100
+ a = ref_c_float128_complex
+ call f_check_c_float128_complex_as(a)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 101
+ a = ref_c_float128_complex
+ call c_check_c_float128_complex_as(a)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 102
+ a = ref_c_float128_complex
+ call f_check_c_float128_complex_ar(a)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 103
+ a = ref_c_float128_complex
+ call c_check_c_float128_complex_ar(a)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 104
+ return
+ end subroutine check_c_float128_complex
+
+ subroutine f_check_c_float128_complex_as(a)
+ complex(kind=c_float128_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 105
+ if(k/=16_c_signed_char) stop 106
+ if(int(k, kind=c_size_t)/=(e/2)) stop 107
+ if(t/=CFI_type_float128_complex) stop 108
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 109
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 110
+ return
+ end subroutine f_check_c_float128_complex_as
+
+ subroutine c_check_c_float128_complex_as(a) bind(c)
+ complex(kind=c_float128_complex), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 111
+ if(k/=16_c_signed_char) stop 112
+ if(int(k, kind=c_size_t)/=(e/2)) stop 113
+ if(t/=CFI_type_float128_complex) stop 114
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 115
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 116
+ return
+ end subroutine c_check_c_float128_complex_as
+
+ subroutine f_check_c_float128_complex_ar(a)
+ complex(kind=c_float128_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 117
+ if(k/=16_c_signed_char) stop 118
+ if(int(k, kind=c_size_t)/=(e/2)) stop 119
+ if(t/=CFI_type_float128_complex) stop 120
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 121
+ rank default
+ stop 122
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 123
+ rank default
+ stop 124
+ end select
+ return
+ end subroutine f_check_c_float128_complex_ar
+
+ subroutine c_check_c_float128_complex_ar(a) bind(c)
+ complex(kind=c_float128_complex), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = kind(a)
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_complex, k)
+ if(k<=0_c_signed_char) stop 125
+ if(k/=16_c_signed_char) stop 126
+ if(int(k, kind=c_size_t)/=(e/2)) stop 127
+ if(t/=CFI_type_float128_complex) stop 128
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 129
+ rank default
+ stop 130
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 131
+ rank default
+ stop 132
+ end select
+ return
+ end subroutine c_check_c_float128_complex_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_float_complex, &
+ check_c_double_complex, &
+ check_c_long_double_complex, &
+ check_c_float128_complex
+
+ implicit none
+
+ call check_c_float_complex()
+ call check_c_double_complex()
+ ! see PR100910
+ ! call check_c_long_double_complex()
+ call check_c_float128_complex()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
new file mode 100644
@@ -0,0 +1,80 @@
+/* Test the fix for PR100915 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+
+#define _CFI_type_mask 0xFF
+#define _CFI_type_kind_shift 8
+
+#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
+#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
+
+#define _CFI_encode_type(TYPE, KIND) (int16_t)\
+((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
+ | ((TYPE) & CFI_type_mask))
+
+#define N 11
+#define M 7
+
+typedef int(*c_funptr)(int);
+
+bool c_vrfy_c_funptr (const CFI_cdesc_t *restrict);
+
+void check_fn (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
+
+bool
+c_vrfy_c_funptr (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_funptr *ip = NULL;
+
+ assert (auxp);
+ assert (auxp->base_addr);
+ assert (auxp->elem_len>0);
+ lb = auxp->dim[0].lower_bound;
+ ex = auxp->dim[0].extent;
+ assert (ex==11);
+ sz = (size_t)auxp->elem_len / sizeof (c_funptr);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_funptr*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if ((**ip)((int)(i)) != 2*(int)(i))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_funptr*)CFI_address(auxp, &i);
+ if ((**ip)((int)(i-lb)) != 2*(int)(i-lb))
+ return false;
+ }
+ return true;
+}
+
+void
+check_fn (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
+{
+ signed char ityp, iknd;
+
+ assert (auxp);
+ assert (auxp->elem_len==elem_len*nelem);
+ assert (auxp->rank==1);
+ assert (auxp->dim[0].sm>0);
+ assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
+ /* */
+ assert (auxp->type==type);
+ ityp = _CFI_decode_type(auxp->type);
+ assert (ityp == CFI_type_cptr);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_c_funptr (auxp));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,272 @@
+! { dg-do run }
+! { dg-additional-sources PR100915.c }
+!
+! Test the fix for PR100915
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_cptr
+
+ public :: &
+ check_fn_as, &
+ check_fn_ar
+
+ public :: &
+ mult2
+
+ public :: &
+ cfi_encode_type
+
+ integer, parameter :: CFI_type_t = c_int16_t
+
+ integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
+ integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
+
+ ! Intrinsic types. Their kind number defines their storage size. */
+ integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7
+
+ interface
+ subroutine check_fn_as(a, t, k, e, n) &
+ bind(c, name="check_fn")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(:)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_fn_as
+ subroutine check_fn_ar(a, t, k, e, n) &
+ bind(c, name="check_fn")
+ use, intrinsic :: iso_c_binding, only: &
+ c_int16_t, c_signed_char, c_size_t
+ implicit none
+ type(*), intent(in) :: a(..)
+ integer(c_int16_t), value, intent(in) :: t
+ integer(c_signed_char), value, intent(in) :: k
+ integer(c_size_t), value, intent(in) :: e
+ integer(c_size_t), value, intent(in) :: n
+ end subroutine check_fn_ar
+ end interface
+
+contains
+
+ function mult2(a) result(b) bind(c)
+ use, intrinsic :: iso_c_binding, only: &
+ c_int
+
+ integer(kind=c_int), value, intent(in) :: a
+
+ integer(kind=c_int) :: b
+
+ b = 2_c_int * a
+ return
+ end function mult2
+
+ elemental function cfi_encode_type(type, kind) result(itype)
+ integer(kind=c_signed_char), intent(in) :: type
+ integer(kind=c_signed_char), intent(in) :: kind
+
+ integer(kind=c_int16_t) :: itype, ikind
+
+ itype = int(type, kind=c_int16_t)
+ itype = iand(itype, CFI_type_mask)
+ ikind = int(kind, kind=c_int16_t)
+ ikind = iand(ikind, CFI_type_mask)
+ ikind = shiftl(ikind, CFI_type_kind_shift)
+ itype = ior(ikind, itype)
+ return
+ end function cfi_encode_type
+
+end module isof_m
+
+module iso_check_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t, c_size_t
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_funptr, c_funloc, c_associated
+
+ use :: isof_m, only: &
+ CFI_type_cptr
+
+ use :: isof_m, only: &
+ check_fn_as, &
+ check_fn_ar
+
+ use :: isof_m, only: &
+ mult2
+
+ use :: isof_m, only: &
+ cfi_encode_type
+
+ implicit none
+
+ integer :: i
+ integer(kind=c_size_t), parameter :: b = 8
+ integer, parameter :: n = 11
+
+contains
+
+ subroutine check_c_funptr()
+ type(c_funptr) :: p(n)
+ integer :: i
+ !
+ p = [(c_funloc(mult2), i=1,n)]
+ call f_check_c_funptr_as(p)
+ do i = 1, n
+ if(.not.c_associated(p(i), c_funloc(mult2))) stop 1
+ end do
+ p = [(c_funloc(mult2), i=1,n)]
+ call c_check_c_funptr_as(p)
+ do i = 1, n
+ if(.not.c_associated(p(i), c_funloc(mult2))) stop 2
+ end do
+ p = [(c_funloc(mult2), i=1,n)]
+ call f_check_c_funptr_ar(p)
+ do i = 1, n
+ if(.not.c_associated(p(i), c_funloc(mult2))) stop 3
+ end do
+ p = [(c_funloc(mult2), i=1,n)]
+ call c_check_c_funptr_ar(p)
+ do i = 1, n
+ if(.not.c_associated(p(i), c_funloc(mult2))) stop 4
+ end do
+ return
+ end subroutine check_c_funptr
+
+ subroutine f_check_c_funptr_as(a)
+ type(c_funptr), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 5
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 6
+ end do
+ call check_fn_as(a, t, k, e, 1_c_size_t)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 7
+ end do
+ return
+ end subroutine f_check_c_funptr_as
+
+ subroutine c_check_c_funptr_as(a) bind(c)
+ type(c_funptr), intent(in) :: a(:)
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 8
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 9
+ end do
+ call check_fn_as(a, t, k, e, 1_c_size_t)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 10
+ end do
+ return
+ end subroutine c_check_c_funptr_as
+
+ subroutine f_check_c_funptr_ar(a)
+ type(c_funptr), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 11
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 12
+ end do
+ rank default
+ stop 13
+ end select
+ call check_fn_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 14
+ end do
+ rank default
+ stop 15
+ end select
+ return
+ end subroutine f_check_c_funptr_ar
+
+ subroutine c_check_c_funptr_ar(a) bind(c)
+ type(c_funptr), intent(in) :: a(..)
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_cptr, k)
+ ! Assumes 64-bit target.
+ ! if(e/=8) stop 16
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 17
+ end do
+ rank default
+ stop 18
+ end select
+ call check_fn_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(.not.c_associated(a(i), c_funloc(mult2))) stop 19
+ end do
+ rank default
+ stop 20
+ end select
+ return
+ end subroutine c_check_c_funptr_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_funptr
+
+ implicit none
+
+ call check_c_funptr()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
@@ -153,10 +153,14 @@ extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
#define CFI_type_Complex 4
#define CFI_type_Character 5
-/* Types with no kind. */
+/* Types with no kind. FIXME: GFC descriptors currently use BT_VOID for
+ both C_PTR and C_FUNPTR, so we have no choice but to make them
+ identical here too. That can potentially break on targets where
+ function and data pointers have different sizes/representations.
+ See PR 100915. */
#define CFI_type_struct 6
#define CFI_type_cptr 7
-#define CFI_type_cfunptr 8
+#define CFI_type_cfunptr CFI_type_cptr
#define CFI_type_other -1
/* Types with kind parameter.
@@ -37,15 +37,16 @@ export_proto(cfi_desc_to_gfc_desc);
void
cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
{
+ signed char type;
+ size_t size;
int n;
- index_type kind;
CFI_cdesc_t *s = *s_ptr;
if (!s)
return;
/* Verify descriptor. */
- switch(s->attribute)
+ switch (s->attribute)
{
case CFI_attribute_pointer:
case CFI_attribute_allocatable:
@@ -63,23 +64,33 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
break;
}
GFC_DESCRIPTOR_DATA (d) = s->base_addr;
- GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
- kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
/* Correct the unfortunate difference in order with types. */
- if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
- GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
- else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
- GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER;
-
- if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
- GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
- else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED)
- GFC_DESCRIPTOR_SIZE (d) = kind;
- else
- GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
+ type = (signed char)(s->type & CFI_type_mask);
+ switch (type)
+ {
+ case CFI_type_Character:
+ type = BT_CHARACTER;
+ break;
+ case CFI_type_struct:
+ type = BT_DERIVED;
+ break;
+ case CFI_type_cptr:
+ /* FIXME: PR 100915. GFC descriptors do not distinguish between
+ CFI_type_cptr and CFI_type_cfunptr. */
+ type = BT_VOID;
+ break;
+ default:
+ break;
+ }
+
+ GFC_DESCRIPTOR_TYPE (d) = (signed char)type;
+ GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
d->dtype.version = 0;
+
+ if (s->rank < 0 || s->rank > CFI_MAX_RANK)
+ internal_error (NULL, "Invalid rank in descriptor");
GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
d->dtype.attribute = (signed short)s->attribute;
@@ -116,13 +127,14 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
{
int n;
CFI_cdesc_t *d;
+ signed char type, kind;
/* Play it safe with allocation of the flexible array member 'dim'
by setting the length to CFI_MAX_RANK. This should not be necessary
but valgrind complains accesses after the allocated block. */
if (*d_ptr == NULL)
- d = malloc (sizeof (CFI_cdesc_t)
- + (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t)));
+ d = calloc (1, (sizeof (CFI_cdesc_t)
+ + (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t))));
else
d = *d_ptr;
@@ -145,20 +157,80 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
}
d->base_addr = GFC_DESCRIPTOR_DATA (s);
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
+ if (d->elem_len <= 0)
+ internal_error (NULL, "Invalid size in descriptor");
+
d->version = CFI_VERSION;
+
d->rank = (CFI_rank_t)GFC_DESCRIPTOR_RANK (s);
+ if (d->rank < 0 || d->rank > CFI_MAX_RANK)
+ internal_error (NULL, "Invalid rank in descriptor");
+
d->attribute = (CFI_attribute_t)s->dtype.attribute;
- if (GFC_DESCRIPTOR_TYPE (s) == BT_CHARACTER)
- d->type = CFI_type_Character;
- else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED)
- d->type = CFI_type_struct;
- else
- d->type = (CFI_type_t)GFC_DESCRIPTOR_TYPE (s);
+ type = GFC_DESCRIPTOR_TYPE (s);
+ switch (type)
+ {
+ case BT_CHARACTER:
+ d->type = CFI_type_Character;
+ break;
+ case BT_DERIVED:
+ d->type = CFI_type_struct;
+ break;
+ case BT_VOID:
+ /* FIXME: PR 100915. GFC descriptors do not distinguish between
+ CFI_type_cptr and CFI_type_cfunptr. */
+ d->type = CFI_type_cptr;
+ break;
+ default:
+ d->type = (CFI_type_t)type;
+ break;
+ }
- if (GFC_DESCRIPTOR_TYPE (s) != BT_DERIVED)
+ switch (d->type)
+ {
+ case CFI_type_Integer:
+ case CFI_type_Logical:
+ case CFI_type_Real:
+ kind = (signed char)d->elem_len;
+ break;
+ case CFI_type_Complex:
+ kind = (signed char)(d->elem_len >> 1);
+ break;
+ case CFI_type_Character:
+ /* FIXME: we can't distinguish between kind/len because
+ the GFC descriptor only encodes the elem_len..
+ Until PR92482 is fixed, assume elem_len refers to the
+ character size and not the string length. */
+ kind = (signed char)d->elem_len;
+ break;
+ case CFI_type_struct:
+ case CFI_type_cptr:
+ case CFI_type_other:
+ /* FIXME: PR 100915. GFC descriptors do not distinguish between
+ CFI_type_cptr and CFI_type_cfunptr. */
+ kind = 0;
+ break;
+ default:
+ internal_error (NULL, "Invalid type in descriptor");
+ }
+
+ if (kind < 0)
+ internal_error (NULL, "Invalid kind in descriptor");
+
+ /* FIXME: This is PR100917. Because the GFC descriptor encodes only the
+ elem_len and not the kind, we get into trouble with long double kinds
+ that do not correspond directly to the elem_len, specifically the
+ kind 10 80-bit long double on x86 targets. On x86_64, this has size
+ 16 and cannot be differentiated from true __float128. Prefer the
+ standard long double type over the GNU extension in that case. */
+ if (d->type == CFI_type_Real && kind == sizeof (long double))
+ d->type = CFI_type_long_double;
+ else if (d->type == CFI_type_Complex && kind == sizeof (long double))
+ d->type = CFI_type_long_double_Complex;
+ else
d->type = (CFI_type_t)(d->type
- + ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
+ + ((CFI_type_t)kind << CFI_type_kind_shift));
if (d->base_addr)
/* Full pointer or allocatable arrays retain their lower_bounds. */