@@ -5781,6 +5781,10 @@ gfc_verify_c_interop (gfc_typespec *ts)
? true : false;
else if (ts->type == BT_CLASS)
return false;
+ /* C_PTR or C_FUNPTR, not BIND(c) but C interop. */
+ else if (ts->u.derived && ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
+ return (ts->u.derived->intmod_sym_id == ISOCBINDING_PTR
+ || ts->u.derived->intmod_sym_id == ISOCBINDING_FUNPTR);
else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
return false;
@@ -273,6 +273,23 @@ gfc_conv_descriptor_elem_len (tree desc)
}
+/* Return the type from the descriptor dtype field. */
+
+tree
+gfc_conv_descriptor_type (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+ GFC_DTYPE_TYPE);
+ gcc_assert (tmp!= NULL_TREE
+ && TREE_TYPE (tmp) == signed_char_type_node);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ dtype, tmp, NULL_TREE);
+}
+
tree
gfc_conv_descriptor_attribute (tree desc)
{
@@ -172,6 +172,7 @@ tree gfc_conv_descriptor_span_get (tree);
tree gfc_conv_descriptor_dtype (tree);
tree gfc_conv_descriptor_rank (tree);
tree gfc_conv_descriptor_elem_len (tree);
+tree gfc_conv_descriptor_type (tree);
tree gfc_conv_descriptor_attribute (tree);
tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
@@ -4512,11 +4512,18 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
&& sym->ts.u.cl->backend_decl
&& VAR_P (sym->ts.u.cl->backend_decl))
{
+ tree type;
+ int bs;
+
+ bs = gfc_validate_kind (BT_CHARACTER, sym->ts.kind, false);
+ bs = gfc_character_kinds[bs].bit_size / 8;
+ gcc_assert (bs > 0);
+ type = TREE_TYPE (sym->ts.u.cl->backend_decl);
tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
- tmp = gfc_conv_descriptor_elem_len (tmp);
- gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
- fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
- tmp));
+ tmp = fold_convert (type, gfc_conv_descriptor_elem_len (tmp));
+ tmp = fold_build2 (EXACT_DIV_EXPR, type, tmp,
+ build_int_cst (type, bs));
+ gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl, tmp);
}
/* Check that the argument is present before executing the above. */
@@ -4526,22 +4533,28 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
gfc_add_expr_to_block (&outer_block, incoming);
incoming = gfc_finish_block (&outer_block);
-
/* Convert the gfc descriptor back to the CFI type before going
out of scope, if the CFI type was present at entry. */
- gfc_init_block (&outer_block);
- gfc_init_block (&tmpblock);
-
- tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
- outgoing = build_call_expr_loc (input_location,
- gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
- gfc_add_expr_to_block (&tmpblock, outgoing);
+ outgoing = NULL_TREE;
+ if ((sym->attr.pointer || sym->attr.allocatable)
+ && !sym->attr.value
+ && sym->attr.intent != INTENT_IN)
+ {
+ gfc_init_block (&outer_block);
+ gfc_init_block (&tmpblock);
- outgoing = build3_v (COND_EXPR, present,
- gfc_finish_block (&tmpblock),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&outer_block, outgoing);
- outgoing = gfc_finish_block (&outer_block);
+ tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+ outgoing = build_call_expr_loc (input_location,
+ gfor_fndecl_gfc_to_cfi, 2,
+ tmp, gfc_desc_ptr);
+ gfc_add_expr_to_block (&tmpblock, outgoing);
+
+ outgoing = build3_v (COND_EXPR, present,
+ gfc_finish_block (&tmpblock),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&outer_block, outgoing);
+ outgoing = gfc_finish_block (&outer_block);
+ }
/* Add the lot to the procedure init and finally blocks. */
gfc_add_init_cleanup (block, incoming, outgoing);
@@ -5485,6 +5485,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
tree gfc_desc_ptr;
tree type;
tree cond;
+ tree gfc_type;
+ tree desc_type;
tree desc_attr;
int attribute;
int cfi_attribute;
@@ -5501,13 +5503,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
attribute = 1;
}
- /* If the formal argument is assumed shape and neither a pointer nor
- allocatable, it is unconditionally CFI_attribute_other. */
- if (fsym->as->type == AS_ASSUMED_SHAPE
- && !fsym->attr.pointer && !fsym->attr.allocatable)
- cfi_attribute = 2;
+ if (fsym->attr.pointer)
+ cfi_attribute = 0;
+ else if (fsym->attr.allocatable)
+ cfi_attribute = 1;
else
- cfi_attribute = attribute;
+ cfi_attribute = 2;
if (e->rank != 0)
{
@@ -5586,6 +5587,17 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
gfc_add_expr_to_block (&parmse->pre, tmp);
+ /* Handle non C interop types. */
+ gfc_type = NULL_TREE;
+ desc_type = gfc_conv_descriptor_type (parmse->expr);
+ if (!gfc_verify_c_interop (&e->ts))
+ {
+ gfc_type = gfc_evaluate_now (desc_type, &parmse->pre);
+ /* CFI_type_other == -1 */
+ tmp = build_int_cst (TREE_TYPE (desc_type), -1);
+ gfc_add_modify (&parmse->pre, desc_type, tmp);
+ }
+
/* Now pass the gfc_descriptor by reference. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
@@ -5607,6 +5619,10 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
build_int_cst (TREE_TYPE (desc_attr), attribute));
gfc_add_expr_to_block (&parmse->pre, tmp);
+ /* Reset descriptor type. */
+ if (gfc_type)
+ gfc_add_modify (&parmse->pre, desc_type, gfc_type);
+
/* The CFI descriptor is passed to the bind_C procedure. */
parmse->expr = cfi_desc_ptr;
@@ -5615,10 +5631,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
gfc_prepend_expr_to_block (&parmse->post, tmp);
/* Transfer values back to gfc descriptor. */
- tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
+ if (cfi_attribute != 2
+ && !fsym->attr.value
+ && fsym->attr.intent != INTENT_IN)
+ {
+ tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
+ }
/* Deal with an optional dummy being passed to an optional formal arg
by finishing the pre and post blocks and making their execution
@@ -12,7 +12,7 @@
type :: mytype
integer :: i
- integer :: j
+ integer(C_INT) :: j
end type
INTERFACE
@@ -39,7 +39,7 @@
USE, INTRINSIC :: ISO_C_BINDING
import
INTEGER(C_INT) :: err
- type (T), DIMENSION(..), intent(out) :: a
+ type (T), pointer, DIMENSION(..), intent(out) :: a
END FUNCTION c_establish
FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
@@ -78,9 +78,9 @@
END INTERFACE
- integer, dimension(:,:), allocatable :: x, y, z
- integer, dimension(2,2) :: a, b, c
- integer, dimension(4,4) :: d
+ integer(C_INT), dimension(:,:), allocatable :: x, y, z
+ integer(C_INT), dimension(2,2) :: a, b, c
+ integer(C_INT), dimension(4,4) :: d
integer :: i = 42, j, k
integer(C_INTPTR_T), dimension(15) :: lower, upper
real, dimension(10,10) :: arg
@@ -183,8 +183,8 @@ end subroutine test_CFI_address
end subroutine test_CFI_contiguous
subroutine test_CFI_section (arg)
- real, dimension (100) :: a
- real, dimension (10,*) :: arg
+ real(C_FLOAT), dimension (100) :: a
+ real(C_FLOAT), dimension (10,*) :: arg
integer, dimension(15) :: lower, strides
integer :: i
new file mode 100644
@@ -0,0 +1,169 @@
+/* Test the fix for PR100906 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+/* #include <uchar.h> */
+
+#include "../../../libgfortran/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 char c_char;
+/* typedef char32_t c_ucs4_char; */
+typedef uint32_t char32_t;
+typedef uint32_t c_ucs4_char;
+
+bool charcmp (char *, char, size_t);
+
+bool ucharcmp (char32_t *, char32_t, size_t);
+
+bool c_vrfy_c_char (const CFI_cdesc_t *restrict, const size_t);
+
+bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, const size_t);
+
+bool c_vrfy_character (const CFI_cdesc_t *restrict, 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
+charcmp (char *c, char v, size_t n)
+{
+ bool res = true;
+ char b = (char)'A';
+ size_t i;
+
+ for (i=0; ((i<n)&&(res)); i++, c++)
+ res = (*c == (v+b));
+ return res;
+}
+
+bool
+ucharcmp (char32_t *c, char32_t v, size_t n)
+{
+ bool res = true;
+ char32_t b = (char32_t)0xFF01;
+ size_t i;
+
+ for (i=0; ((i<n)&&(res)); i++, c++)
+ res = (*c == (v+b));
+ return res;
+}
+
+bool
+c_vrfy_c_char (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_char *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==N);
+ sz = (size_t)auxp->elem_len / sizeof (c_char);
+ assert (sz==len);
+ ub = ex + lb - 1;
+ ip = (c_char*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if (!charcmp (ip, (c_char)(i), sz))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_char*)CFI_address(auxp, &i);
+ if (!charcmp (ip, (c_char)(i-lb), sz))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_ucs4_char *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==N);
+ sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char);
+ assert (sz==len);
+ ub = ex + lb - 1;
+ ip = (c_ucs4_char*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if (!ucharcmp (ip, (c_ucs4_char)(i), sz))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_ucs4_char*)CFI_address(auxp, &i);
+ if (!ucharcmp (ip, (c_ucs4_char)(i-lb), sz))
+ return false;
+ }
+ return true;
+}
+
+bool
+c_vrfy_character (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+ signed char type, kind;
+
+ assert (auxp);
+ type = _CFI_decode_type(auxp->type);
+ kind = _CFI_decode_kind(auxp->type);
+ assert (type == CFI_type_Character);
+ switch (kind)
+ {
+ case 1:
+ return c_vrfy_c_char (auxp, len);
+ break;
+ case 4:
+ return c_vrfy_c_ucs4_char (auxp, len);
+ 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_Character);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_character (auxp, nelem));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,1699 @@
+! { dg-do run }
+! { dg-additional-sources PR100906.c }
+!
+! Test the fix for PR100906
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_character
+
+ public :: &
+ CFI_type_char, &
+ CFI_type_ucs4_char
+
+ 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_Character = 5
+
+ ! C-Fortran Interoperability types.
+ integer(kind=cfi_type_t), parameter :: CFI_type_char = &
+ ior(int(CFI_type_Character, kind=c_int16_t), shiftl(1_c_int16_t, CFI_type_kind_shift))
+ integer(kind=cfi_type_t), parameter :: CFI_type_ucs4_char = &
+ ior(int(CFI_type_Character, kind=c_int16_t), shiftl(4_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_char
+
+ use :: isof_m, only: &
+ CFI_type_character
+
+ use :: isof_m, only: &
+ CFI_type_char, &
+ CFI_type_ucs4_char
+
+ use :: isof_m, only: &
+ check_tk_as, &
+ check_tk_ar
+
+ use :: isof_m, only: &
+ cfi_encode_type
+
+ implicit none
+
+ private
+
+ public :: &
+ check_c_char_l1, &
+ check_c_char_lm, &
+ check_c_ucs4_char_l1, &
+ check_c_ucs4_char_lm
+
+ integer :: i
+ integer(kind=c_size_t), parameter :: b = 8
+ integer, parameter :: n = 11
+ integer, parameter :: m = 7
+
+ integer, parameter :: c_ucs4_char = 4
+
+ character(kind=c_char, len=1), parameter :: ref_c_char_l1(*) = &
+ [(achar(i+iachar("A")-1, kind=c_char), i=1,n)]
+ character(kind=c_char, len=m), parameter :: ref_c_char_lm(*) = &
+ [(repeat(achar(i+iachar("A")-1, kind=c_char), m), i=1,n)]
+ character(kind=c_ucs4_char, len=1), parameter :: ref_c_ucs4_char_l1(*) = &
+ [(achar(i+iachar("A")-1, kind=c_ucs4_char), i=1,n)]
+ character(kind=c_ucs4_char, len=m), parameter :: ref_c_ucs4_char_lm(*) = &
+ [(repeat(achar(i+iachar("A")-1, kind=c_ucs4_char), m), i=1,n)]
+
+contains
+
+ subroutine check_c_char_l1()
+ character(kind=c_char, len=1), target :: a(n)
+ !
+ character(kind=c_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_char_l1
+ call f_check_c_char_c1_as(a)
+ if(any(a/=ref_c_char_l1)) stop 1
+ a = ref_c_char_l1
+ call c_check_c_char_c1_as(a)
+ if(any(a/=ref_c_char_l1)) stop 2
+ a = ref_c_char_l1
+ call f_check_c_char_c1_ar(a)
+ if(any(a/=ref_c_char_l1)) stop 3
+ a = ref_c_char_l1
+ call c_check_c_char_c1_ar(a)
+ if(any(a/=ref_c_char_l1)) stop 4
+ a = ref_c_char_l1
+ call f_check_c_char_a1_as(a)
+ if(any(a/=ref_c_char_l1)) stop 5
+ a = ref_c_char_l1
+ call c_check_c_char_a1_as(a)
+ if(any(a/=ref_c_char_l1)) stop 6
+ a = ref_c_char_l1
+ call f_check_c_char_a1_ar(a)
+ if(any(a/=ref_c_char_l1)) stop 7
+ a = ref_c_char_l1
+ call c_check_c_char_a1_ar(a)
+ if(any(a/=ref_c_char_l1)) stop 8
+ a = ref_c_char_l1
+ p => a
+ call f_check_c_char_d1_as(p)
+ if(.not.associated(p)) stop 9
+ if(.not.associated(p, a)) stop 10
+ if(any(p/=ref_c_char_l1)) stop 11
+ if(any(a/=ref_c_char_l1)) stop 12
+ a = ref_c_char_l1
+ p => a
+ call c_check_c_char_d1_as(p)
+ if(.not.associated(p)) stop 13
+ if(.not.associated(p, a)) stop 14
+ if(any(p/=ref_c_char_l1)) stop 15
+ if(any(a/=ref_c_char_l1)) stop 16
+ a = ref_c_char_l1
+ p => a
+ call f_check_c_char_d1_ar(p)
+ if(.not.associated(p)) stop 17
+ if(.not.associated(p, a)) stop 18
+ if(any(p/=ref_c_char_l1)) stop 19
+ if(any(a/=ref_c_char_l1)) stop 20
+ a = ref_c_char_l1
+ p => a
+ call c_check_c_char_d1_ar(p)
+ if(.not.associated(p)) stop 21
+ if(.not.associated(p, a)) stop 22
+ if(any(p/=ref_c_char_l1)) stop 23
+ if(any(a/=ref_c_char_l1)) stop 24
+ return
+ end subroutine check_c_char_l1
+
+ subroutine f_check_c_char_c1_as(a)
+ character(kind=c_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 25
+ if(k/=1_c_signed_char) stop 26
+ if(n/=1) stop 27
+ if(int(k, kind=c_size_t)/=e) stop 28
+ if(t/=CFI_type_char) stop 29
+ if(any(a/=ref_c_char_l1)) stop 30
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 31
+ return
+ end subroutine f_check_c_char_c1_as
+
+ subroutine c_check_c_char_c1_as(a) bind(c)
+ character(kind=c_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 32
+ if(k/=1_c_signed_char) stop 33
+ if(n/=1) stop 34
+ if(int(k, kind=c_size_t)/=e) stop 35
+ if(t/=CFI_type_char) stop 36
+ if(any(a/=ref_c_char_l1)) stop 37
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 38
+ return
+ end subroutine c_check_c_char_c1_as
+
+ subroutine f_check_c_char_c1_ar(a)
+ character(kind=c_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 39
+ if(k/=1_c_signed_char) stop 40
+ if(n/=1) stop 41
+ if(int(k, kind=c_size_t)/=e) stop 42
+ if(t/=CFI_type_char) stop 43
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 44
+ rank default
+ stop 45
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 46
+ rank default
+ stop 47
+ end select
+ return
+ end subroutine f_check_c_char_c1_ar
+
+ subroutine c_check_c_char_c1_ar(a) bind(c)
+ character(kind=c_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 48
+ if(k/=1_c_signed_char) stop 49
+ if(n/=1) stop 50
+ if(int(k, kind=c_size_t)/=e) stop 51
+ if(t/=CFI_type_char) stop 52
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 53
+ rank default
+ stop 54
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 55
+ rank default
+ stop 56
+ end select
+ return
+ end subroutine c_check_c_char_c1_ar
+
+ subroutine f_check_c_char_a1_as(a)
+ character(kind=c_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 57
+ if(k/=1_c_signed_char) stop 58
+ if(n/=1) stop 59
+ if(int(k, kind=c_size_t)/=e) stop 60
+ if(t/=CFI_type_char) stop 61
+ if(any(a/=ref_c_char_l1)) stop 62
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 63
+ return
+ end subroutine f_check_c_char_a1_as
+
+ subroutine c_check_c_char_a1_as(a) bind(c)
+ character(kind=c_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 64
+ if(k/=1_c_signed_char) stop 65
+ if(n/=1) stop 66
+ if(int(k, kind=c_size_t)/=e) stop 67
+ if(t/=CFI_type_char) stop 68
+ if(any(a/=ref_c_char_l1)) stop 69
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 70
+ return
+ end subroutine c_check_c_char_a1_as
+
+ subroutine f_check_c_char_a1_ar(a)
+ character(kind=c_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 71
+ if(k/=1_c_signed_char) stop 72
+ if(n/=1) stop 73
+ if(int(k, kind=c_size_t)/=e) stop 74
+ if(t/=CFI_type_char) stop 75
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 76
+ rank default
+ stop 77
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 78
+ rank default
+ stop 79
+ end select
+ return
+ end subroutine f_check_c_char_a1_ar
+
+ subroutine c_check_c_char_a1_ar(a) bind(c)
+ character(kind=c_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 80
+ if(k/=1_c_signed_char) stop 81
+ if(n/=1) stop 82
+ if(int(k, kind=c_size_t)/=e) stop 83
+ if(t/=CFI_type_char) stop 84
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 85
+ rank default
+ stop 86
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 87
+ rank default
+ stop 88
+ end select
+ return
+ end subroutine c_check_c_char_a1_ar
+
+ subroutine f_check_c_char_d1_as(a)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 89
+ if(k/=1_c_signed_char) stop 90
+ if(n/=1) stop 91
+ if(int(k, kind=c_size_t)/=e) stop 92
+ if(t/=CFI_type_char) stop 93
+ if(any(a/=ref_c_char_l1)) stop 94
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 95
+ return
+ end subroutine f_check_c_char_d1_as
+
+ subroutine c_check_c_char_d1_as(a) bind(c)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 96
+ if(k/=1_c_signed_char) stop 97
+ if(n/=1) stop 98
+ if(int(k, kind=c_size_t)/=e) stop 99
+ if(t/=CFI_type_char) stop 100
+ if(any(a/=ref_c_char_l1)) stop 101
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_l1)) stop 102
+ return
+ end subroutine c_check_c_char_d1_as
+
+ subroutine f_check_c_char_d1_ar(a)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 103
+ if(k/=1_c_signed_char) stop 104
+ if(n/=1) stop 105
+ if(int(k, kind=c_size_t)/=e) stop 106
+ if(t/=CFI_type_char) stop 107
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 108
+ rank default
+ stop 109
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 110
+ rank default
+ stop 111
+ end select
+ return
+ end subroutine f_check_c_char_d1_ar
+
+ subroutine c_check_c_char_d1_ar(a) bind(c)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 112
+ if(k/=1_c_signed_char) stop 113
+ if(n/=1) stop 114
+ if(int(k, kind=c_size_t)/=e) stop 115
+ if(t/=CFI_type_char) stop 116
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 117
+ rank default
+ stop 118
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_l1)) stop 119
+ rank default
+ stop 120
+ end select
+ return
+ end subroutine c_check_c_char_d1_ar
+
+ subroutine check_c_char_lm()
+ character(kind=c_char, len=m), target :: a(n)
+ !
+ character(kind=c_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_char_lm
+ call f_check_c_char_cm_as(a)
+ if(any(a/=ref_c_char_lm)) stop 121
+ a = ref_c_char_lm
+ call c_check_c_char_cm_as(a)
+ if(any(a/=ref_c_char_lm)) stop 122
+ a = ref_c_char_lm
+ call f_check_c_char_cm_ar(a)
+ if(any(a/=ref_c_char_lm)) stop 123
+ a = ref_c_char_lm
+ call c_check_c_char_cm_ar(a)
+ if(any(a/=ref_c_char_lm)) stop 124
+ a = ref_c_char_lm
+ call f_check_c_char_am_as(a)
+ if(any(a/=ref_c_char_lm)) stop 125
+ a = ref_c_char_lm
+ call c_check_c_char_am_as(a)
+ if(any(a/=ref_c_char_lm)) stop 126
+ a = ref_c_char_lm
+ call f_check_c_char_am_ar(a)
+ if(any(a/=ref_c_char_lm)) stop 127
+ a = ref_c_char_lm
+ call c_check_c_char_am_ar(a)
+ if(any(a/=ref_c_char_lm)) stop 128
+ a = ref_c_char_lm
+ p => a
+ call f_check_c_char_dm_as(p)
+ if(.not.associated(p)) stop 129
+ if(.not.associated(p, a)) stop 130
+ if(any(p/=ref_c_char_lm)) stop 131
+ if(any(a/=ref_c_char_lm)) stop 132
+ a = ref_c_char_lm
+ p => a
+ call c_check_c_char_dm_as(p)
+ if(.not.associated(p)) stop 133
+ if(.not.associated(p, a)) stop 134
+ if(any(p/=ref_c_char_lm)) stop 135
+ if(any(a/=ref_c_char_lm)) stop 136
+ a = ref_c_char_lm
+ p => a
+ call f_check_c_char_dm_ar(p)
+ if(.not.associated(p)) stop 137
+ if(.not.associated(p, a)) stop 138
+ if(any(p/=ref_c_char_lm)) stop 139
+ if(any(a/=ref_c_char_lm)) stop 140
+ a = ref_c_char_lm
+ p => a
+ call c_check_c_char_dm_ar(p)
+ if(.not.associated(p)) stop 141
+ if(.not.associated(p, a)) stop 142
+ if(any(p/=ref_c_char_lm)) stop 143
+ if(any(a/=ref_c_char_lm)) stop 144
+ return
+ end subroutine check_c_char_lm
+
+ subroutine f_check_c_char_cm_as(a)
+ character(kind=c_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 145
+ if(k/=1_c_signed_char) stop 146
+ if(n/=m) stop 147
+ if(int(k, kind=c_size_t)/=e) stop 148
+ if(t/=CFI_type_char) stop 149
+ if(any(a/=ref_c_char_lm)) stop 150
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 151
+ return
+ end subroutine f_check_c_char_cm_as
+
+ subroutine c_check_c_char_cm_as(a) bind(c)
+ character(kind=c_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 152
+ if(k/=1_c_signed_char) stop 153
+ if(n/=m) stop 154
+ if(int(k, kind=c_size_t)/=e) stop 155
+ if(t/=CFI_type_char) stop 156
+ if(any(a/=ref_c_char_lm)) stop 157
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 158
+ return
+ end subroutine c_check_c_char_cm_as
+
+ subroutine f_check_c_char_cm_ar(a)
+ character(kind=c_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 159
+ if(k/=1_c_signed_char) stop 160
+ if(n/=m) stop 161
+ if(int(k, kind=c_size_t)/=e) stop 162
+ if(t/=CFI_type_char) stop 163
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 164
+ rank default
+ stop 165
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 166
+ rank default
+ stop 167
+ end select
+ return
+ end subroutine f_check_c_char_cm_ar
+
+ subroutine c_check_c_char_cm_ar(a) bind(c)
+ character(kind=c_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 168
+ if(k/=1_c_signed_char) stop 169
+ if(n/=m) stop 170
+ if(int(k, kind=c_size_t)/=e) stop 171
+ if(t/=CFI_type_char) stop 172
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 173
+ rank default
+ stop 174
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 175
+ rank default
+ stop 176
+ end select
+ return
+ end subroutine c_check_c_char_cm_ar
+
+ subroutine f_check_c_char_am_as(a)
+ character(kind=c_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 177
+ if(k/=1_c_signed_char) stop 178
+ if(n/=m) stop 179
+ if(int(k, kind=c_size_t)/=e) stop 180
+ if(t/=CFI_type_char) stop 181
+ if(any(a/=ref_c_char_lm)) stop 182
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 183
+ return
+ end subroutine f_check_c_char_am_as
+
+ subroutine c_check_c_char_am_as(a) bind(c)
+ character(kind=c_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 184
+ if(k/=1_c_signed_char) stop 185
+ if(n/=m) stop 186
+ if(int(k, kind=c_size_t)/=e) stop 187
+ if(t/=CFI_type_char) stop 188
+ if(any(a/=ref_c_char_lm)) stop 189
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 190
+ return
+ end subroutine c_check_c_char_am_as
+
+ subroutine f_check_c_char_am_ar(a)
+ character(kind=c_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 191
+ if(k/=1_c_signed_char) stop 192
+ if(n/=m) stop 193
+ if(int(k, kind=c_size_t)/=e) stop 194
+ if(t/=CFI_type_char) stop 195
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 196
+ rank default
+ stop 197
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 198
+ rank default
+ stop 199
+ end select
+ return
+ end subroutine f_check_c_char_am_ar
+
+ subroutine c_check_c_char_am_ar(a) bind(c)
+ character(kind=c_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 200
+ if(k/=1_c_signed_char) stop 201
+ if(n/=m) stop 202
+ if(int(k, kind=c_size_t)/=e) stop 203
+ if(t/=CFI_type_char) stop 204
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 205
+ rank default
+ stop 206
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 207
+ rank default
+ stop 208
+ end select
+ return
+ end subroutine c_check_c_char_am_ar
+
+ subroutine f_check_c_char_dm_as(a)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 209
+ if(k/=1_c_signed_char) stop 210
+ if(n/=m) stop 211
+ if(int(k, kind=c_size_t)/=e) stop 212
+ if(t/=CFI_type_char) stop 213
+ if(any(a/=ref_c_char_lm)) stop 214
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 215
+ return
+ end subroutine f_check_c_char_dm_as
+
+ subroutine c_check_c_char_dm_as(a) bind(c)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 216
+ if(k/=1_c_signed_char) stop 217
+ if(n/=m) stop 218
+ if(int(k, kind=c_size_t)/=e) stop 219
+ if(t/=CFI_type_char) stop 220
+ if(any(a/=ref_c_char_lm)) stop 221
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_char_lm)) stop 222
+ return
+ end subroutine c_check_c_char_dm_as
+
+ subroutine f_check_c_char_dm_ar(a)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 223
+ if(k/=1_c_signed_char) stop 224
+ if(n/=m) stop 225
+ if(int(k, kind=c_size_t)/=e) stop 226
+ if(t/=CFI_type_char) stop 227
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 228
+ rank default
+ stop 229
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 230
+ rank default
+ stop 231
+ end select
+ return
+ end subroutine f_check_c_char_dm_ar
+
+ subroutine c_check_c_char_dm_ar(a) bind(c)
+ character(kind=c_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 232
+ if(k/=1_c_signed_char) stop 233
+ if(n/=m) stop 234
+ if(int(k, kind=c_size_t)/=e) stop 235
+ if(t/=CFI_type_char) stop 236
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 237
+ rank default
+ stop 238
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_char_lm)) stop 239
+ rank default
+ stop 240
+ end select
+ return
+ end subroutine c_check_c_char_dm_ar
+
+ subroutine check_c_ucs4_char_l1()
+ character(kind=c_ucs4_char, len=1), target :: a(n)
+ !
+ character(kind=c_ucs4_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_c1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 241
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_c1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 242
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_c1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 243
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_c1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 244
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_a1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 245
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_a1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 246
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_a1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 247
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_a1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 248
+ a = ref_c_ucs4_char_l1
+ p => a
+ call f_check_c_ucs4_char_d1_as(p)
+ if(.not.associated(p)) stop 249
+ if(.not.associated(p, a)) stop 250
+ if(any(p/=ref_c_ucs4_char_l1)) stop 251
+ if(any(a/=ref_c_ucs4_char_l1)) stop 252
+ a = ref_c_ucs4_char_l1
+ p => a
+ call c_check_c_ucs4_char_d1_as(p)
+ if(.not.associated(p)) stop 253
+ if(.not.associated(p, a)) stop 254
+ if(any(p/=ref_c_ucs4_char_l1)) stop 255
+ if(any(a/=ref_c_ucs4_char_l1)) stop 256
+ a = ref_c_ucs4_char_l1
+ p => a
+ call f_check_c_ucs4_char_d1_ar(p)
+ if(.not.associated(p)) stop 257
+ if(.not.associated(p, a)) stop 258
+ if(any(p/=ref_c_ucs4_char_l1)) stop 259
+ if(any(a/=ref_c_ucs4_char_l1)) stop 260
+ a = ref_c_ucs4_char_l1
+ p => a
+ call c_check_c_ucs4_char_d1_ar(p)
+ if(.not.associated(p)) stop 261
+ if(.not.associated(p, a)) stop 262
+ if(any(p/=ref_c_ucs4_char_l1)) stop 263
+ if(any(a/=ref_c_ucs4_char_l1)) stop 264
+ return
+ end subroutine check_c_ucs4_char_l1
+
+ subroutine f_check_c_ucs4_char_c1_as(a)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 265
+ if(k/=4_c_signed_char) stop 266
+ if(n/=1) stop 267
+ if(int(k, kind=c_size_t)/=e) stop 268
+ if(t/=CFI_type_ucs4_char) stop 269
+ if(any(a/=ref_c_ucs4_char_l1)) stop 270
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 271
+ return
+ end subroutine f_check_c_ucs4_char_c1_as
+
+ subroutine c_check_c_ucs4_char_c1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 272
+ if(k/=4_c_signed_char) stop 273
+ if(n/=1) stop 274
+ if(int(k, kind=c_size_t)/=e) stop 275
+ if(t/=CFI_type_ucs4_char) stop 276
+ if(any(a/=ref_c_ucs4_char_l1)) stop 277
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 278
+ return
+ end subroutine c_check_c_ucs4_char_c1_as
+
+ subroutine f_check_c_ucs4_char_c1_ar(a)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 279
+ if(k/=4_c_signed_char) stop 280
+ if(n/=1) stop 281
+ if(int(k, kind=c_size_t)/=e) stop 282
+ if(t/=CFI_type_ucs4_char) stop 283
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 284
+ rank default
+ stop 285
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 286
+ rank default
+ stop 287
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_c1_ar
+
+ subroutine c_check_c_ucs4_char_c1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 288
+ if(k/=4_c_signed_char) stop 289
+ if(n/=1) stop 290
+ if(int(k, kind=c_size_t)/=e) stop 291
+ if(t/=CFI_type_ucs4_char) stop 292
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 293
+ rank default
+ stop 294
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 295
+ rank default
+ stop 296
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_c1_ar
+
+ subroutine f_check_c_ucs4_char_a1_as(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 297
+ if(k/=4_c_signed_char) stop 298
+ if(n/=1) stop 299
+ if(int(k, kind=c_size_t)/=e) stop 300
+ if(t/=CFI_type_ucs4_char) stop 301
+ if(any(a/=ref_c_ucs4_char_l1)) stop 302
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 303
+ return
+ end subroutine f_check_c_ucs4_char_a1_as
+
+ subroutine c_check_c_ucs4_char_a1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 304
+ if(k/=4_c_signed_char) stop 305
+ if(n/=1) stop 306
+ if(int(k, kind=c_size_t)/=e) stop 307
+ if(t/=CFI_type_ucs4_char) stop 308
+ if(any(a/=ref_c_ucs4_char_l1)) stop 309
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 310
+ return
+ end subroutine c_check_c_ucs4_char_a1_as
+
+ subroutine f_check_c_ucs4_char_a1_ar(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 311
+ if(k/=4_c_signed_char) stop 312
+ if(n/=1) stop 313
+ if(int(k, kind=c_size_t)/=e) stop 314
+ if(t/=CFI_type_ucs4_char) stop 315
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 316
+ rank default
+ stop 317
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 318
+ rank default
+ stop 319
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_a1_ar
+
+ subroutine c_check_c_ucs4_char_a1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 320
+ if(k/=4_c_signed_char) stop 321
+ if(n/=1) stop 322
+ if(int(k, kind=c_size_t)/=e) stop 323
+ if(t/=CFI_type_ucs4_char) stop 324
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 325
+ rank default
+ stop 326
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 327
+ rank default
+ stop 328
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_a1_ar
+
+ subroutine f_check_c_ucs4_char_d1_as(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 329
+ if(k/=4_c_signed_char) stop 330
+ if(n/=1) stop 331
+ if(int(k, kind=c_size_t)/=e) stop 332
+ if(t/=CFI_type_ucs4_char) stop 333
+ if(any(a/=ref_c_ucs4_char_l1)) stop 334
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 335
+ return
+ end subroutine f_check_c_ucs4_char_d1_as
+
+ subroutine c_check_c_ucs4_char_d1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 336
+ if(k/=4_c_signed_char) stop 337
+ if(n/=1) stop 338
+ if(int(k, kind=c_size_t)/=e) stop 339
+ if(t/=CFI_type_ucs4_char) stop 340
+ if(any(a/=ref_c_ucs4_char_l1)) stop 341
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 342
+ return
+ end subroutine c_check_c_ucs4_char_d1_as
+
+ subroutine f_check_c_ucs4_char_d1_ar(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 343
+ if(k/=4_c_signed_char) stop 344
+ if(n/=1) stop 345
+ if(int(k, kind=c_size_t)/=e) stop 346
+ if(t/=CFI_type_ucs4_char) stop 347
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 348
+ rank default
+ stop 349
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 350
+ rank default
+ stop 351
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_d1_ar
+
+ subroutine c_check_c_ucs4_char_d1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 352
+ if(k/=4_c_signed_char) stop 353
+ if(n/=1) stop 354
+ if(int(k, kind=c_size_t)/=e) stop 355
+ if(t/=CFI_type_ucs4_char) stop 356
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 357
+ rank default
+ stop 358
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 359
+ rank default
+ stop 360
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_d1_ar
+
+ subroutine check_c_ucs4_char_lm()
+ character(kind=c_ucs4_char, len=m), target :: a(n)
+ !
+ character(kind=c_ucs4_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_cm_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 361
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_cm_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 362
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_cm_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 363
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_cm_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 364
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_am_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 365
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_am_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 366
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_am_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 367
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_am_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 368
+ a = ref_c_ucs4_char_lm
+ p => a
+ call f_check_c_ucs4_char_dm_as(p)
+ if(.not.associated(p)) stop 369
+ if(.not.associated(p, a)) stop 370
+ if(any(p/=ref_c_ucs4_char_lm)) stop 371
+ if(any(a/=ref_c_ucs4_char_lm)) stop 372
+ a = ref_c_ucs4_char_lm
+ p => a
+ call c_check_c_ucs4_char_dm_as(p)
+ if(.not.associated(p)) stop 373
+ if(.not.associated(p, a)) stop 374
+ if(any(p/=ref_c_ucs4_char_lm)) stop 375
+ if(any(a/=ref_c_ucs4_char_lm)) stop 376
+ a = ref_c_ucs4_char_lm
+ p => a
+ call f_check_c_ucs4_char_dm_ar(p)
+ if(.not.associated(p)) stop 377
+ if(.not.associated(p, a)) stop 378
+ if(any(p/=ref_c_ucs4_char_lm)) stop 379
+ if(any(a/=ref_c_ucs4_char_lm)) stop 380
+ a = ref_c_ucs4_char_lm
+ p => a
+ call c_check_c_ucs4_char_dm_ar(p)
+ if(.not.associated(p)) stop 381
+ if(.not.associated(p, a)) stop 382
+ if(any(p/=ref_c_ucs4_char_lm)) stop 383
+ if(any(a/=ref_c_ucs4_char_lm)) stop 384
+ return
+ end subroutine check_c_ucs4_char_lm
+
+ subroutine f_check_c_ucs4_char_cm_as(a)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 385
+ if(k/=4_c_signed_char) stop 386
+ if(n/=m) stop 387
+ if(int(k, kind=c_size_t)/=e) stop 388
+ if(t/=CFI_type_ucs4_char) stop 389
+ if(any(a/=ref_c_ucs4_char_lm)) stop 390
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 391
+ return
+ end subroutine f_check_c_ucs4_char_cm_as
+
+ subroutine c_check_c_ucs4_char_cm_as(a) bind(c)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 392
+ if(k/=4_c_signed_char) stop 393
+ if(n/=m) stop 394
+ if(int(k, kind=c_size_t)/=e) stop 395
+ if(t/=CFI_type_ucs4_char) stop 396
+ if(any(a/=ref_c_ucs4_char_lm)) stop 397
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 398
+ return
+ end subroutine c_check_c_ucs4_char_cm_as
+
+ subroutine f_check_c_ucs4_char_cm_ar(a)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 399
+ if(k/=4_c_signed_char) stop 400
+ if(n/=m) stop 401
+ if(int(k, kind=c_size_t)/=e) stop 402
+ if(t/=CFI_type_ucs4_char) stop 403
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 404
+ rank default
+ stop 405
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 406
+ rank default
+ stop 407
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_cm_ar
+
+ subroutine c_check_c_ucs4_char_cm_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 408
+ if(k/=4_c_signed_char) stop 409
+ if(n/=m) stop 410
+ if(int(k, kind=c_size_t)/=e) stop 411
+ if(t/=CFI_type_ucs4_char) stop 412
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 413
+ rank default
+ stop 414
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 415
+ rank default
+ stop 416
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_cm_ar
+
+ subroutine f_check_c_ucs4_char_am_as(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 417
+ if(k/=4_c_signed_char) stop 418
+ if(n/=m) stop 419
+ if(int(k, kind=c_size_t)/=e) stop 420
+ if(t/=CFI_type_ucs4_char) stop 421
+ if(any(a/=ref_c_ucs4_char_lm)) stop 422
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 423
+ return
+ end subroutine f_check_c_ucs4_char_am_as
+
+ subroutine c_check_c_ucs4_char_am_as(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 424
+ if(k/=4_c_signed_char) stop 425
+ if(n/=m) stop 426
+ if(int(k, kind=c_size_t)/=e) stop 427
+ if(t/=CFI_type_ucs4_char) stop 428
+ if(any(a/=ref_c_ucs4_char_lm)) stop 429
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 430
+ return
+ end subroutine c_check_c_ucs4_char_am_as
+
+ subroutine f_check_c_ucs4_char_am_ar(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 431
+ if(k/=4_c_signed_char) stop 432
+ if(n/=m) stop 433
+ if(int(k, kind=c_size_t)/=e) stop 434
+ if(t/=CFI_type_ucs4_char) stop 435
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 436
+ rank default
+ stop 437
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 438
+ rank default
+ stop 439
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_am_ar
+
+ subroutine c_check_c_ucs4_char_am_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 440
+ if(k/=4_c_signed_char) stop 441
+ if(n/=m) stop 442
+ if(int(k, kind=c_size_t)/=e) stop 443
+ if(t/=CFI_type_ucs4_char) stop 444
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 445
+ rank default
+ stop 446
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 447
+ rank default
+ stop 448
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_am_ar
+
+ subroutine f_check_c_ucs4_char_dm_as(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 449
+ if(k/=4_c_signed_char) stop 450
+ if(n/=m) stop 451
+ if(int(k, kind=c_size_t)/=e) stop 452
+ if(t/=CFI_type_ucs4_char) stop 453
+ if(any(a/=ref_c_ucs4_char_lm)) stop 454
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 455
+ return
+ end subroutine f_check_c_ucs4_char_dm_as
+
+ subroutine c_check_c_ucs4_char_dm_as(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 456
+ if(k/=4_c_signed_char) stop 457
+ if(n/=m) stop 458
+ if(int(k, kind=c_size_t)/=e) stop 459
+ if(t/=CFI_type_ucs4_char) stop 460
+ if(any(a/=ref_c_ucs4_char_lm)) stop 461
+ call check_tk_as(a, t, k, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 462
+ return
+ end subroutine c_check_c_ucs4_char_dm_as
+
+ subroutine f_check_c_ucs4_char_dm_ar(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 463
+ if(k/=4_c_signed_char) stop 464
+ if(n/=m) stop 465
+ if(int(k, kind=c_size_t)/=e) stop 466
+ if(t/=CFI_type_ucs4_char) stop 467
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 468
+ rank default
+ stop 469
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 470
+ rank default
+ stop 471
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_dm_ar
+
+ subroutine c_check_c_ucs4_char_dm_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_Character, k)
+ if(k<=0_c_signed_char) stop 472
+ if(k/=4_c_signed_char) stop 473
+ if(n/=m) stop 474
+ if(int(k, kind=c_size_t)/=e) stop 475
+ if(t/=CFI_type_ucs4_char) stop 476
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 477
+ rank default
+ stop 478
+ end select
+ call check_tk_ar(a, t, k, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 479
+ rank default
+ stop 480
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_dm_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_char_l1, &
+ check_c_char_lm, &
+ check_c_ucs4_char_l1, &
+ check_c_ucs4_char_lm
+
+ implicit none
+
+ call check_c_char_l1()
+ call check_c_char_lm()
+ ! See PR100907
+ !call check_c_ucs4_char_l1()
+ !call check_c_ucs4_char_lm()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
new file mode 100644
@@ -0,0 +1,98 @@
+/* Test the fix for PR100907 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+/* #include <uchar.h> */
+
+#include "../../../libgfortran/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 char32_t c_ucs4_char; */
+typedef uint32_t char32_t;
+typedef uint32_t c_ucs4_char;
+
+bool ucharcmp (char32_t *, char32_t, size_t);
+
+bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, 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
+ucharcmp (char32_t *c, char32_t v, size_t n)
+{
+ bool res = true;
+ char32_t b = (char32_t)0xFF01;
+ size_t i;
+
+ for (i=0; ((i<n)&&(res)); i++, c++)
+ res = (*c == (v+b));
+ return res;
+}
+
+bool
+c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_ucs4_char *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==N);
+ sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char);
+ assert (sz==len);
+ ub = ex + lb - 1;
+ ip = (c_ucs4_char*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if (!ucharcmp (ip, (c_ucs4_char)(i), sz))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_ucs4_char*)CFI_address(auxp, &i);
+ if (!ucharcmp (ip, (c_ucs4_char)(i-lb), sz))
+ 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_other);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_c_ucs4_char (auxp, nelem));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,904 @@
+! { dg-do run }
+! { dg-additional-sources PR100907.c }
+!
+! Test the fix for PR100907
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_other
+
+ public :: &
+ check_tk_as, &
+ check_tk_ar
+
+
+ public :: &
+ cfi_encode_type
+
+ 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_other =-1
+
+ 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_char
+
+ use :: isof_m, only: &
+ CFI_type_other
+
+ use :: isof_m, only: &
+ check_tk_as, &
+ check_tk_ar
+
+ use :: isof_m, only: &
+ cfi_encode_type
+
+ implicit none
+
+ private
+
+ public :: &
+ check_c_ucs4_char_l1, &
+ check_c_ucs4_char_lm
+
+ integer :: i
+ integer(kind=c_size_t), parameter :: b = 8
+ integer, parameter :: n = 11
+ integer, parameter :: m = 7
+
+ integer, parameter :: c_ucs4_char = selected_char_kind("ISO_10646")
+
+ character(kind=c_ucs4_char, len=1), parameter :: ref_c_ucs4_char_l1(*) = &
+ [(achar(i+int(z"FF00"), kind=c_ucs4_char), i=1,n)]
+ character(kind=c_ucs4_char, len=m), parameter :: ref_c_ucs4_char_lm(*) = &
+ [(repeat(achar(i+int(z"FF00"), kind=c_ucs4_char), m), i=1,n)]
+
+contains
+
+ subroutine check_c_ucs4_char_l1()
+ character(kind=c_ucs4_char, len=1), target :: a(n)
+ !
+ character(kind=c_ucs4_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_c1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 241
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_c1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 242
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_c1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 243
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_c1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 244
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_a1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 245
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_a1_as(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 246
+ a = ref_c_ucs4_char_l1
+ call f_check_c_ucs4_char_a1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 247
+ a = ref_c_ucs4_char_l1
+ call c_check_c_ucs4_char_a1_ar(a)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 248
+ a = ref_c_ucs4_char_l1
+ p => a
+ call f_check_c_ucs4_char_d1_as(p)
+ if(.not.associated(p)) stop 249
+ if(.not.associated(p, a)) stop 250
+ if(any(p/=ref_c_ucs4_char_l1)) stop 251
+ if(any(a/=ref_c_ucs4_char_l1)) stop 252
+ a = ref_c_ucs4_char_l1
+ p => a
+ call c_check_c_ucs4_char_d1_as(p)
+ if(.not.associated(p)) stop 253
+ if(.not.associated(p, a)) stop 254
+ if(any(p/=ref_c_ucs4_char_l1)) stop 255
+ if(any(a/=ref_c_ucs4_char_l1)) stop 256
+ a = ref_c_ucs4_char_l1
+ p => a
+ call f_check_c_ucs4_char_d1_ar(p)
+ if(.not.associated(p)) stop 257
+ if(.not.associated(p, a)) stop 258
+ if(any(p/=ref_c_ucs4_char_l1)) stop 259
+ if(any(a/=ref_c_ucs4_char_l1)) stop 260
+ a = ref_c_ucs4_char_l1
+ p => a
+ call c_check_c_ucs4_char_d1_ar(p)
+ if(.not.associated(p)) stop 261
+ if(.not.associated(p, a)) stop 262
+ if(any(p/=ref_c_ucs4_char_l1)) stop 263
+ if(any(a/=ref_c_ucs4_char_l1)) stop 264
+ return
+ end subroutine check_c_ucs4_char_l1
+
+ subroutine f_check_c_ucs4_char_c1_as(a)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 265
+ if(k/=4_c_signed_char) stop 266
+ if(n/=1) stop 267
+ if(int(k, kind=c_size_t)/=e) stop 268
+ if(t/=255_c_int16_t) stop 269
+ if(any(a/=ref_c_ucs4_char_l1)) stop 270
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 271
+ return
+ end subroutine f_check_c_ucs4_char_c1_as
+
+ subroutine c_check_c_ucs4_char_c1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 272
+ if(k/=4_c_signed_char) stop 273
+ if(n/=1) stop 274
+ if(int(k, kind=c_size_t)/=e) stop 275
+ if(t/=255_c_int16_t) stop 276
+ if(any(a/=ref_c_ucs4_char_l1)) stop 277
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 278
+ return
+ end subroutine c_check_c_ucs4_char_c1_as
+
+ subroutine f_check_c_ucs4_char_c1_ar(a)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 279
+ if(k/=4_c_signed_char) stop 280
+ if(n/=1) stop 281
+ if(int(k, kind=c_size_t)/=e) stop 282
+ if(t/=255_c_int16_t) stop 283
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 284
+ rank default
+ stop 285
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 286
+ rank default
+ stop 287
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_c1_ar
+
+ subroutine c_check_c_ucs4_char_c1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 288
+ if(k/=4_c_signed_char) stop 289
+ if(n/=1) stop 290
+ if(int(k, kind=c_size_t)/=e) stop 291
+ if(t/=255_c_int16_t) stop 292
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 293
+ rank default
+ stop 294
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 295
+ rank default
+ stop 296
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_c1_ar
+
+ subroutine f_check_c_ucs4_char_a1_as(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 297
+ if(k/=4_c_signed_char) stop 298
+ if(n/=1) stop 299
+ if(int(k, kind=c_size_t)/=e) stop 300
+ if(t/=255_c_int16_t) stop 301
+ if(any(a/=ref_c_ucs4_char_l1)) stop 302
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 303
+ return
+ end subroutine f_check_c_ucs4_char_a1_as
+
+ subroutine c_check_c_ucs4_char_a1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 304
+ if(k/=4_c_signed_char) stop 305
+ if(n/=1) stop 306
+ if(int(k, kind=c_size_t)/=e) stop 307
+ if(t/=255_c_int16_t) stop 308
+ if(any(a/=ref_c_ucs4_char_l1)) stop 309
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 310
+ return
+ end subroutine c_check_c_ucs4_char_a1_as
+
+ subroutine f_check_c_ucs4_char_a1_ar(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 311
+ if(k/=4_c_signed_char) stop 312
+ if(n/=1) stop 313
+ if(int(k, kind=c_size_t)/=e) stop 314
+ if(t/=255_c_int16_t) stop 315
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 316
+ rank default
+ stop 317
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 318
+ rank default
+ stop 319
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_a1_ar
+
+ subroutine c_check_c_ucs4_char_a1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 320
+ if(k/=4_c_signed_char) stop 321
+ if(n/=1) stop 322
+ if(int(k, kind=c_size_t)/=e) stop 323
+ if(t/=255_c_int16_t) stop 324
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 325
+ rank default
+ stop 326
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 327
+ rank default
+ stop 328
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_a1_ar
+
+ subroutine f_check_c_ucs4_char_d1_as(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 329
+ if(k/=4_c_signed_char) stop 330
+ if(n/=1) stop 331
+ if(int(k, kind=c_size_t)/=e) stop 332
+ if(t/=255_c_int16_t) stop 333
+ if(any(a/=ref_c_ucs4_char_l1)) stop 334
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 335
+ return
+ end subroutine f_check_c_ucs4_char_d1_as
+
+ subroutine c_check_c_ucs4_char_d1_as(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 336
+ if(k/=4_c_signed_char) stop 337
+ if(n/=1) stop 338
+ if(int(k, kind=c_size_t)/=e) stop 339
+ if(t/=255_c_int16_t) stop 340
+ if(any(a/=ref_c_ucs4_char_l1)) stop 341
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 342
+ return
+ end subroutine c_check_c_ucs4_char_d1_as
+
+ subroutine f_check_c_ucs4_char_d1_ar(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 343
+ if(k/=4_c_signed_char) stop 344
+ if(n/=1) stop 345
+ if(int(k, kind=c_size_t)/=e) stop 346
+ if(t/=255_c_int16_t) stop 347
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 348
+ rank default
+ stop 349
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 350
+ rank default
+ stop 351
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_d1_ar
+
+ subroutine c_check_c_ucs4_char_d1_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*1)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 352
+ if(k/=4_c_signed_char) stop 353
+ if(n/=1) stop 354
+ if(int(k, kind=c_size_t)/=e) stop 355
+ if(t/=255_c_int16_t) stop 356
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 357
+ rank default
+ stop 358
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_l1)) stop 359
+ rank default
+ stop 360
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_d1_ar
+
+ subroutine check_c_ucs4_char_lm()
+ character(kind=c_ucs4_char, len=m), target :: a(n)
+ !
+ character(kind=c_ucs4_char, len=:), pointer :: p(:)
+ !
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_cm_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 361
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_cm_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 362
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_cm_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 363
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_cm_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 364
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_am_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 365
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_am_as(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 366
+ a = ref_c_ucs4_char_lm
+ call f_check_c_ucs4_char_am_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 367
+ a = ref_c_ucs4_char_lm
+ call c_check_c_ucs4_char_am_ar(a)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 368
+ a = ref_c_ucs4_char_lm
+ p => a
+ call f_check_c_ucs4_char_dm_as(p)
+ if(.not.associated(p)) stop 369
+ if(.not.associated(p, a)) stop 370
+ if(any(p/=ref_c_ucs4_char_lm)) stop 371
+ if(any(a/=ref_c_ucs4_char_lm)) stop 372
+ a = ref_c_ucs4_char_lm
+ p => a
+ call c_check_c_ucs4_char_dm_as(p)
+ if(.not.associated(p)) stop 373
+ if(.not.associated(p, a)) stop 374
+ if(any(p/=ref_c_ucs4_char_lm)) stop 375
+ if(any(a/=ref_c_ucs4_char_lm)) stop 376
+ a = ref_c_ucs4_char_lm
+ p => a
+ call f_check_c_ucs4_char_dm_ar(p)
+ if(.not.associated(p)) stop 377
+ if(.not.associated(p, a)) stop 378
+ if(any(p/=ref_c_ucs4_char_lm)) stop 379
+ if(any(a/=ref_c_ucs4_char_lm)) stop 380
+ a = ref_c_ucs4_char_lm
+ p => a
+ call c_check_c_ucs4_char_dm_ar(p)
+ if(.not.associated(p)) stop 381
+ if(.not.associated(p, a)) stop 382
+ if(any(p/=ref_c_ucs4_char_lm)) stop 383
+ if(any(a/=ref_c_ucs4_char_lm)) stop 384
+ return
+ end subroutine check_c_ucs4_char_lm
+
+ subroutine f_check_c_ucs4_char_cm_as(a)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 385
+ if(k/=4_c_signed_char) stop 386
+ if(n/=m) stop 387
+ if(int(k, kind=c_size_t)/=e) stop 388
+ if(t/=255_c_int16_t) stop 389
+ if(any(a/=ref_c_ucs4_char_lm)) stop 390
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 391
+ return
+ end subroutine f_check_c_ucs4_char_cm_as
+
+ subroutine c_check_c_ucs4_char_cm_as(a) bind(c)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 392
+ if(k/=4_c_signed_char) stop 393
+ if(n/=m) stop 394
+ if(int(k, kind=c_size_t)/=e) stop 395
+ if(t/=255_c_int16_t) stop 396
+ if(any(a/=ref_c_ucs4_char_lm)) stop 397
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 398
+ return
+ end subroutine c_check_c_ucs4_char_cm_as
+
+ subroutine f_check_c_ucs4_char_cm_ar(a)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 399
+ if(k/=4_c_signed_char) stop 400
+ if(n/=m) stop 401
+ if(int(k, kind=c_size_t)/=e) stop 402
+ if(t/=255_c_int16_t) stop 403
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 404
+ rank default
+ stop 405
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 406
+ rank default
+ stop 407
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_cm_ar
+
+ subroutine c_check_c_ucs4_char_cm_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 408
+ if(k/=4_c_signed_char) stop 409
+ if(n/=m) stop 410
+ if(int(k, kind=c_size_t)/=e) stop 411
+ if(t/=255_c_int16_t) stop 412
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 413
+ rank default
+ stop 414
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 415
+ rank default
+ stop 416
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_cm_ar
+
+ subroutine f_check_c_ucs4_char_am_as(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 417
+ if(k/=4_c_signed_char) stop 418
+ if(n/=m) stop 419
+ if(int(k, kind=c_size_t)/=e) stop 420
+ if(t/=255_c_int16_t) stop 421
+ if(any(a/=ref_c_ucs4_char_lm)) stop 422
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 423
+ return
+ end subroutine f_check_c_ucs4_char_am_as
+
+ subroutine c_check_c_ucs4_char_am_as(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 424
+ if(k/=4_c_signed_char) stop 425
+ if(n/=m) stop 426
+ if(int(k, kind=c_size_t)/=e) stop 427
+ if(t/=255_c_int16_t) stop 428
+ if(any(a/=ref_c_ucs4_char_lm)) stop 429
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 430
+ return
+ end subroutine c_check_c_ucs4_char_am_as
+
+ subroutine f_check_c_ucs4_char_am_ar(a)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 431
+ if(k/=4_c_signed_char) stop 432
+ if(n/=m) stop 433
+ if(int(k, kind=c_size_t)/=e) stop 434
+ if(t/=255_c_int16_t) stop 435
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 436
+ rank default
+ stop 437
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 438
+ rank default
+ stop 439
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_am_ar
+
+ subroutine c_check_c_ucs4_char_am_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 440
+ if(k/=4_c_signed_char) stop 441
+ if(n/=m) stop 442
+ if(int(k, kind=c_size_t)/=e) stop 443
+ if(t/=255_c_int16_t) stop 444
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 445
+ rank default
+ stop 446
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 447
+ rank default
+ stop 448
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_am_ar
+
+ subroutine f_check_c_ucs4_char_dm_as(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 449
+ if(k/=4_c_signed_char) stop 450
+ if(n/=m) stop 451
+ if(int(k, kind=c_size_t)/=e) stop 452
+ if(t/=255_c_int16_t) stop 453
+ if(any(a/=ref_c_ucs4_char_lm)) stop 454
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 455
+ return
+ end subroutine f_check_c_ucs4_char_dm_as
+
+ subroutine c_check_c_ucs4_char_dm_as(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 456
+ if(k/=4_c_signed_char) stop 457
+ if(n/=m) stop 458
+ if(int(k, kind=c_size_t)/=e) stop 459
+ if(t/=255_c_int16_t) stop 460
+ if(any(a/=ref_c_ucs4_char_lm)) stop 461
+ call check_tk_as(a, t, 0_c_signed_char, e, n)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 462
+ return
+ end subroutine c_check_c_ucs4_char_dm_as
+
+ subroutine f_check_c_ucs4_char_dm_ar(a)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 463
+ if(k/=4_c_signed_char) stop 464
+ if(n/=m) stop 465
+ if(int(k, kind=c_size_t)/=e) stop 466
+ if(t/=255_c_int16_t) stop 467
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 468
+ rank default
+ stop 469
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 470
+ rank default
+ stop 471
+ end select
+ return
+ end subroutine f_check_c_ucs4_char_dm_ar
+
+ subroutine c_check_c_ucs4_char_dm_ar(a) bind(c)
+ character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, n
+ !
+ k = kind(a)
+ n = len(a, kind=kind(e))
+ e = storage_size(a, kind=kind(e))/(b*m)
+ t = cfi_encode_type(CFI_type_other, 0_c_signed_char)
+ if(k<=0_c_signed_char) stop 472
+ if(k/=4_c_signed_char) stop 473
+ if(n/=m) stop 474
+ if(int(k, kind=c_size_t)/=e) stop 475
+ if(t/=255_c_int16_t) stop 476
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 477
+ rank default
+ stop 478
+ end select
+ call check_tk_ar(a, t, 0_c_signed_char, e, n)
+ select rank(a)
+ rank(1)
+ if(any(a/=ref_c_ucs4_char_lm)) stop 479
+ rank default
+ stop 480
+ end select
+ return
+ end subroutine c_check_c_ucs4_char_dm_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_ucs4_char_l1, &
+ check_c_ucs4_char_lm
+
+ implicit none
+
+ call check_c_ucs4_char_l1()
+ call check_c_ucs4_char_lm()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
new file mode 100644
@@ -0,0 +1,82 @@
+/* Test the fix for PR100911 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdio.h>
+
+#include "../../../libgfortran/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,278 @@
+! { 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)
+ 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)
+ 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)
+ 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)
+ 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 "../../../libgfortran/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,649 @@
+! { dg-do run }
+! { dg-additional-sources PR100914.c }
+!
+! 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 "../../../libgfortran/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,268 @@
+! { 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)
+ 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)
+ 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)
+ 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)
+ 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:
+
new file mode 100644
@@ -0,0 +1,103 @@
+/* Test the fix for PR100916 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdio.h>
+
+#include "../../../libgfortran/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_Other CFI_type_other
+
+struct c_struct_tag
+{
+ int a[M];
+};
+
+typedef struct c_struct_tag c_struct;
+typedef struct c_struct_tag c_other;
+
+bool structcmp (c_struct*, int, size_t);
+
+bool c_vrfy_other (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
+structcmp (c_struct *c, int v, size_t n)
+{
+ bool res = true;
+ int *p = NULL;
+ size_t i;
+
+ p = c->a;
+ for (i=0; ((i<n)&&(res)); i++, p++)
+ res = (*p == v);
+ return res;
+}
+
+bool
+c_vrfy_other (const CFI_cdesc_t *restrict auxp)
+{
+ CFI_index_t i, lb, ub, ex;
+ size_t sz;
+ c_other *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_other);
+ assert (sz==1);
+ ub = ex + lb - 1;
+ ip = (c_other*)auxp->base_addr;
+ for (i=0; i<ex; i++, ip+=sz)
+ if (!structcmp (ip, (int)(i+1), 7))
+ return false;
+ for (i=lb; i<ub+1; i++)
+ {
+ ip = (c_other*)CFI_address(auxp, &i);
+ if (!structcmp (ip, (int)(i-lb+1), 7))
+ 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_Other);
+ iknd = _CFI_decode_kind(auxp->type);
+ assert (_CFI_decode_type(type)==ityp);
+ assert (kind==iknd);
+ assert (c_vrfy_other (auxp));
+ return;
+}
+
+// Local Variables:
+// mode: C
+// End:
new file mode 100644
@@ -0,0 +1,256 @@
+! { dg-do run }
+! { dg-additional-sources PR100916.c }
+!
+! Test the fix for PR100916
+!
+
+module isof_m
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_signed_char, c_int16_t
+
+ implicit none
+
+ private
+
+ public :: &
+ CFI_type_other
+
+ 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_other =-1
+
+ 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_loc, c_f_pointer
+
+ use :: isof_m, only: &
+ CFI_type_other
+
+ 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
+ integer, parameter :: m = 7
+
+
+ type :: c_other
+ integer(kind=c_int) :: a(m)
+ end type c_other
+
+ type(c_other), parameter :: ref_c_other(*) = [(c_other(a=i), i=1,n)]
+
+contains
+
+ ! CFI_type_other
+ subroutine check_c_other()
+ type(c_other) :: a(n)
+ !
+ a = ref_c_other
+ call f_check_c_other_as(a)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 1
+ end do
+ a = ref_c_other
+ call c_check_c_other_as(a)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 2
+ end do
+ a = ref_c_other
+ call f_check_c_other_ar(a)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 3
+ end do
+ a = ref_c_other
+ call c_check_c_other_ar(a)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 4
+ end do
+ return
+ end subroutine check_c_other
+
+ subroutine f_check_c_other_as(a)
+ type(c_other), intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, i
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_other, k)
+ if(e/=4*m) stop 5
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 6
+ end do
+ call check_tk_as(a, t, k, e, 1_c_size_t)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 7
+ end do
+ return
+ end subroutine f_check_c_other_as
+
+ subroutine c_check_c_other_as(a) bind(c)
+ type(*), target, intent(in) :: a(:)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, i
+ !
+ type(c_other), pointer :: p(:)
+ !
+ call c_f_pointer(c_loc(a), p, [n])
+ k = 0
+ e = storage_size(p)/b
+ t = cfi_encode_type(CFI_type_other, k)
+ if(e/=4*m) stop 8
+ do i = 1, n
+ if(any(p(i)%a/=ref_c_other(i)%a)) stop 9
+ end do
+ call check_tk_as(p, t, k, e, 1_c_size_t)
+ do i = 1, n
+ if(any(p(i)%a/=ref_c_other(i)%a)) stop 10
+ end do
+ return
+ end subroutine c_check_c_other_as
+
+ subroutine f_check_c_other_ar(a)
+ type(c_other), intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, i
+ !
+ k = 0
+ e = storage_size(a)/b
+ t = cfi_encode_type(CFI_type_other, k)
+ if(e/=4*m) stop 11
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 12
+ end do
+ rank default
+ stop 13
+ end select
+ call check_tk_ar(a, t, k, e, 1_c_size_t)
+ select rank(a)
+ rank(1)
+ do i = 1, n
+ if(any(a(i)%a/=ref_c_other(i)%a)) stop 14
+ end do
+ rank default
+ stop 15
+ end select
+ return
+ end subroutine f_check_c_other_ar
+
+ subroutine c_check_c_other_ar(a) bind(c)
+ type(*), target, intent(in) :: a(..)
+ !
+ integer(kind=c_int16_t) :: t
+ integer(kind=c_signed_char) :: k
+ integer(kind=c_size_t) :: e, i
+ !
+ type(c_other), pointer :: p(:)
+ !
+ call c_f_pointer(c_loc(a), p, [n])
+ k = 0
+ e = storage_size(p)/b
+ t = cfi_encode_type(CFI_type_other, k)
+ if(e/=4*m) stop 16
+ do i = 1, n
+ if(any(p(i)%a/=ref_c_other(i)%a)) stop 17
+ end do
+ call check_tk_as(p, t, k, e, 1_c_size_t)
+ do i = 1, n
+ if(any(p(i)%a/=ref_c_other(i)%a)) stop 18
+ end do
+ return
+ end subroutine c_check_c_other_ar
+
+end module iso_check_m
+
+program main_p
+
+ use :: iso_check_m, only: &
+ check_c_other
+
+ implicit none
+
+ call check_c_other()
+ stop
+
+end program main_p
+
+!! Local Variables:
+!! mode: f90
+!! End:
+
@@ -22,4 +22,4 @@ end
! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } }
! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } }
-! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } }
@@ -145,6 +145,15 @@ extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
#define CFI_type_mask 0xFF
#define CFI_type_kind_shift 8
+/* Extract type and kind from a CFI type. */
+#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)
+/* Encode type and kind into a CFI type. */
+#define _CFI_ENCODE_TYPE(TYPE, KIND) \
+ (CFI_type_t)((((KIND) & CFI_type_mask) << CFI_type_kind_shift) \
+ | ((TYPE) & CFI_type_mask))
+
/* Intrinsic types. Their kind number defines their storage size. */
#define CFI_type_Integer 1
#define CFI_type_Logical 2
@@ -36,31 +36,81 @@ 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, kind;
+ size_t size;
int n;
- index_type kind;
CFI_cdesc_t *s = *s_ptr;
if (!s)
return;
+ /* Verify descriptor. */
+ switch(s->attribute)
+ {
+ case CFI_attribute_pointer:
+ case CFI_attribute_allocatable:
+ break;
+ case CFI_attribute_other:
+ if (s->base_addr)
+ break;
+ /* FALL THROUGH */
+ default:
+ internal_error (NULL, "INVALID CFI DESCRIPTOR");
+ 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 = _CFI_DECODE_TYPE (s->type);
+ switch (type)
+ {
+ case CFI_type_Character:
+ type = BT_CHARACTER;
+ break;
+ case CFI_type_struct:
+ type = BT_DERIVED;
+ break;
+ case CFI_type_cptr:
+ type = BT_VOID;
+ break;
+ default:
+ break;
+ }
+ kind = _CFI_DECODE_KIND (s->type);
+ switch(type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ size = (size_t)kind;
+ break;
+ case BT_COMPLEX:
+ size = (size_t)(kind << 1);
+ break;
+ case BT_DERIVED:
+ case BT_CHARACTER:
+ case BT_VOID:
+ size = s->elem_len;
+ break;
+ default:
+ if (type != CFI_type_other)
+ internal_error(NULL, "TYPE ERROR");
+ size = s->elem_len;
+ break;
+ }
+
+ GFC_DESCRIPTOR_TYPE (d) = (signed char)type;
+
+ if (size <= 0)
+ internal_error(NULL, "SIZE ERROR");
+ GFC_DESCRIPTOR_SIZE (d) = size;
+
d->dtype.version = s->version;
+
+ if ((s->rank < 0) || (s->rank > CFI_MAX_RANK))
+ internal_error(NULL, "Rank out of range.");
GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
d->dtype.attribute = (signed short)s->attribute;
@@ -74,14 +124,19 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
}
d->offset = 0;
- for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
- {
- GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
- GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
- + s->dim[n].lower_bound - 1);
- GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
- d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
- }
+ if (GFC_DESCRIPTOR_DATA (d))
+ for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
+ {
+ CFI_index_t lb = 1;
+
+ if (s->attribute != CFI_attribute_other)
+ lb = s->dim[n].lower_bound;
+
+ GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)lb;
+ GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent + lb - 1);
+ GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
+ d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
+ }
}
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
@@ -92,32 +147,87 @@ 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)
+ d = calloc (1, sizeof (CFI_cdesc_t)
+ (CFI_type_t)(CFI_MAX_RANK * sizeof (CFI_dim_t)));
else
d = *d_ptr;
+ /* Verify descriptor. */
+ switch (s->dtype.attribute)
+ {
+ case CFI_attribute_pointer:
+ case CFI_attribute_allocatable:
+ break;
+ case CFI_attribute_other:
+ if (s->base_addr)
+ break;
+ /* FALL THROUGH */
+ default:
+ internal_error (NULL, "INVALID GFC DESCRIPTOR");
+ break;
+ }
+
d->base_addr = GFC_DESCRIPTOR_DATA (s);
d->elem_len = GFC_DESCRIPTOR_SIZE (s);
+ if (d->elem_len <= 0)
+ internal_error(NULL, "SIZE ERROR");
+
d->version = s->dtype.version;
+
d->rank = (CFI_rank_t)GFC_DESCRIPTOR_RANK (s);
+ if ((d->rank < 0) || (d->rank > CFI_MAX_RANK))
+ internal_error(NULL, "Rank out of range.");
+
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:
+ d->type = CFI_type_cptr;
+ break;
+ default:
+ d->type = (CFI_type_t)type;
+ break;
+ }
+
+ 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:
+ kind = 1;
+ break;
+ case CFI_type_struct:
+ case CFI_type_cptr:
+ case CFI_type_other:
+ kind = 0;
+ break;
+ default:
+ internal_error(NULL, "TYPE ERROR");
+ }
- if (GFC_DESCRIPTOR_TYPE (s) != BT_DERIVED)
- d->type = (CFI_type_t)(d->type
- + ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
+ if (kind < 0)
+ internal_error(NULL, "SIZE ERROR");
+ d->type = _CFI_ENCODE_TYPE(d->type, kind);
if (d->base_addr)
/* Full pointer or allocatable arrays retain their lower_bounds. */