From patchwork Sun Jun 13 18:36:04 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Patchwork-Id: 1491488 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=NMn37eb4; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4G33G45dbFz9sW6 for ; Mon, 14 Jun 2021 04:36:59 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id BB3973890032 for ; Sun, 13 Jun 2021 18:36:56 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org BB3973890032 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1623609416; bh=YFeIP/6o5u/2hl09hBC1FRgT819nooR0z7PF5bPwbI0=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=NMn37eb42PHCtPpyQ3bpg7FsBCUZ+BTtaVNuZz4EsKBpgDsbMR3rYVX5bX4gQF4LN aoWQA/qdGblO8Ke1b6ASGHiMFhoZegAAHsHdDhRiqxeFZdZtl95TUgAtktRYudCskE TKtUkfChqGfZOrLiZ8i3Nx6T0wa1iSyZU5oQPr50= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x335.google.com (mail-wm1-x335.google.com [IPv6:2a00:1450:4864:20::335]) by sourceware.org (Postfix) with ESMTPS id 269C03853828; Sun, 13 Jun 2021 18:36:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 269C03853828 Received: by mail-wm1-x335.google.com with SMTP id s70-20020a1ca9490000b02901a589651424so8408301wme.0; Sun, 13 Jun 2021 11:36:08 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:to:from:subject:message-id:date:user-agent :mime-version:content-language; bh=YFeIP/6o5u/2hl09hBC1FRgT819nooR0z7PF5bPwbI0=; b=WhAcT4mBVQNOuUIC2xXV2vePYhhibo+LdSik9pWz8IGxSA7PyG1s3qYe5/7+GFrG9U GXkRamR+JtfyAoMmhTcC1QGdRxUaW/OitI/zbP3uP0wdJQS4PDpFc20cFdj4OPMeLnza 3TrNL/PILKl42bUFDnpMnesJJE6lYyyFwDCxzKMZlFACvapS3ch3DIFDe8X+6S7IRcV4 bbN4GBQzdlRSEL2ILglV2ieOSidnOztPWCPPyWg/9LYe8tHEPuwF2cvZ8XWm/XSJrkPR NIJWPaUSneHafjAxrwUqbeQ+l55p7JNQsoVjvMZeiSD18vny3okVX4h6jzlFjOLSLhmv kzqQ== X-Gm-Message-State: AOAM532FJzRjzfpbiNgkNinGn2k5mKRH3rkcvJPqX3fcmtN6G0vc7AiU wL5fTPHgrLycqPex4NXqeCRgDW5JWQE= X-Google-Smtp-Source: ABdhPJzaU96JkUoxJRkBpldXG88iix1MgPzLNXr9MVkJ2xKXEujmtpjHaPi4DMktv781uu/H+0iM6A== X-Received: by 2002:a1c:ba88:: with SMTP id k130mr5178325wmf.158.1623609366707; Sun, 13 Jun 2021 11:36:06 -0700 (PDT) Received: from ?IPv6:2001:8a0:7d79:6000:9731:6be6:13d:4409? ([2001:8a0:7d79:6000:9731:6be6:13d:4409]) by smtp.googlemail.com with ESMTPSA id j12sm13335135wrt.69.2021.06.13.11.36.05 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Sun, 13 Jun 2021 11:36:06 -0700 (PDT) To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [Patch, fortran] PR fortran/100906/100907/100911/100914/100915/100916 Message-ID: <0653caee-14bd-6ac9-76c4-c3b09413cfa5@gmail.com> Date: Sun, 13 Jun 2021 18:36:04 +0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.8.1 MIME-Version: 1.0 Content-Language: en-US X-Spam-Status: No, score=-11.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_NUMSUBJECT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa_via_Gcc-patches?= From: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Reply-To: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Hi All! Proposed patch to: Bug 100906 - Bind(c): failure handling character with len/=1 Bug 100907 - Bind(c): failure handling wide character Bug 100911 - Bind(c): failure handling C_PTR Bug 100914 - Bind(c): errors handling complex Bug 100915 - Bind(c): failure handling C_FUNPTR Bug 100916 - Bind(c): CFI_type_other unimplemented Patch tested only on x86_64-pc-linux-gnu. This patch deals with improving C interoperability. The identification of type and kind is improved, support for C_PTR and C_FUNPTR is introduced, non interoperability types are now properly marked as CFI_type_other. This patch partially depends on the patch: "PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling" Thank you very much. Best regards, José Rui Fortran: Fixes to type and kind handling in ISO_Fortran_binding. gcc/fortran/ChangeLog: PR fortran/100907 PR fortran/100911 PR fortran/100915 PR fortran/100916 * decl.c (gfc_verify_c_interop): add missing C_PTR and C_FUNPTR as C interop types. * trans-array.c (gfc_conv_descriptor_type): new function to access the type field from the dtype descriptor field. * trans-array.h (gfc_conv_descriptor_type): new prototype. * trans-decl.c (convert_CFI_desc): add support for handlinng non C interop wide character type. * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): add support for CFI_type_other. libgfortran/ChangeLog: PR fortran/100906 PR fortran/100907 PR fortran/100911 PR fortran/100914 PR fortran/100915 PR fortran/100916 * ISO_Fortran_binding.h: adds helper macros to handle type and kind conversion between CFI and GFC descriptors. (_CFI_DECODE_TYPE): extract type from an encoded CFI type. (_CFI_DECODE_KIND): extract kind from an encoded CFI type. (_CFI_ENCODE_TYPE): encode a CFI type. * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): improvements to the handling of type and kind information. (gfc_desc_to_cfi_desc): improvements to the handling of type and kind information. gcc/testsuite/ChangeLog: PR fortran/100906 PR fortran/100907 PR fortran/100911 PR fortran/100914 PR fortran/100915 PR fortran/100916 * gfortran.dg/ISO_Fortran_binding_1.f90: * gfortran.dg/bind_c_array_params_2.f90: * gfortran.dg/PR100906.c: New test. * gfortran.dg/PR100906.f90: New test. * gfortran.dg/PR100907.c: New test. * gfortran.dg/PR100907.f90: New test. * gfortran.dg/PR100911.c: New test. * gfortran.dg/PR100911.f90: New test. * gfortran.dg/PR100914.c: New test. * gfortran.dg/PR100914.f90: New test. * gfortran.dg/PR100915.c: New test. * gfortran.dg/PR100915.f90: New test. * gfortran.dg/PR100916.c: New test. * gfortran.dg/PR100916.f90: New test. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 413c7a7..ca12554 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a6bcd2b..d55b3bc 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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) { diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index e4d443d..2b19374 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -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); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index c32bd05..2718ee0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index de406ad..4631348 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 102bc60..08095c4 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/PR100906.c b/gcc/testsuite/gfortran.dg/PR100906.c new file mode 100644 index 0000000..3bf3513 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100906.c @@ -0,0 +1,169 @@ +/* Test the fix for PR100906 */ + +#include +#include +#include +#include +/* #include */ + +#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; ((ibase_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; ibase_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; itype); + 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: diff --git a/gcc/testsuite/gfortran.dg/PR100906.f90 b/gcc/testsuite/gfortran.dg/PR100906.f90 new file mode 100644 index 0000000..f6cb3af --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100906.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/PR100907.c b/gcc/testsuite/gfortran.dg/PR100907.c new file mode 100644 index 0000000..e0fe499 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100907.c @@ -0,0 +1,98 @@ +/* Test the fix for PR100907 */ + +#include +#include +#include +#include +/* #include */ + +#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; ((ibase_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; ielem_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: diff --git a/gcc/testsuite/gfortran.dg/PR100907.f90 b/gcc/testsuite/gfortran.dg/PR100907.f90 new file mode 100644 index 0000000..2bceb66 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100907.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/PR100911.c b/gcc/testsuite/gfortran.dg/PR100911.c new file mode 100644 index 0000000..eff04df --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100911.c @@ -0,0 +1,82 @@ +/* Test the fix for PR100911 */ + +#include +#include +#include + +#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; ielem_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: diff --git a/gcc/testsuite/gfortran.dg/PR100911.f90 b/gcc/testsuite/gfortran.dg/PR100911.f90 new file mode 100644 index 0000000..a7db897 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100911.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/PR100914.c b/gcc/testsuite/gfortran.dg/PR100914.c new file mode 100644 index 0000000..7d21ff8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100914.c @@ -0,0 +1,226 @@ +/* Test the fix for PR100914 */ + +#include +#include +#include +#include +#include +#include + +#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(float)0.0)) + return false; + for (i=lb; i(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(double)0.0)) + return false; + for (i=lb; i(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(long double)0.0)) + return false; + for (i=lb; i(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(double)0.0)) + return false; + for (i=lb; i(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: diff --git a/gcc/testsuite/gfortran.dg/PR100914.f90 b/gcc/testsuite/gfortran.dg/PR100914.f90 new file mode 100644 index 0000000..3288a2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100914.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/PR100915.c b/gcc/testsuite/gfortran.dg/PR100915.c new file mode 100644 index 0000000..d4dbf17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100915.c @@ -0,0 +1,80 @@ +/* Test the fix for PR100915 */ + +#include +#include +#include + +#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; ielem_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: diff --git a/gcc/testsuite/gfortran.dg/PR100915.f90 b/gcc/testsuite/gfortran.dg/PR100915.f90 new file mode 100644 index 0000000..82872f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100915.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/PR100916.c b/gcc/testsuite/gfortran.dg/PR100916.c new file mode 100644 index 0000000..64c3469 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100916.c @@ -0,0 +1,103 @@ +/* Test the fix for PR100916 */ + +#include +#include +#include + +#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; ((ibase_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; ielem_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: diff --git a/gcc/testsuite/gfortran.dg/PR100916.f90 b/gcc/testsuite/gfortran.dg/PR100916.f90 new file mode 100644 index 0000000..be4c4b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100916.f90 @@ -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: + diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 00628c1..ede6eff 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -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" } } diff --git a/libgfortran/ISO_Fortran_binding.h b/libgfortran/ISO_Fortran_binding.h index 6c4d461..c8c2fa7 100644 --- a/libgfortran/ISO_Fortran_binding.h +++ b/libgfortran/ISO_Fortran_binding.h @@ -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 diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 20833ad..3a269d7 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -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. */