--- /dev/null
+/* 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:
--- /dev/null
+! { 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:
+
--- /dev/null
+/* 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:
--- /dev/null
+! 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:
+
--- /dev/null
+/* 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:
--- /dev/null
+! { 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:
+
#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.
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:
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) = 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;
{
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;
}
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. */