From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 7A1793857419; Thu, 1 Jul 2021 17:09:03 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 7A1793857419 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: J5c3giNdTbcbsSCdfygxbNyUS64IMtDEXEf9xik5pkJA0ykI9pQQwI61YzVmtqRBYdch2gftGa ZD0eCW6CzQkTol1UxOBrqydTw/RwfBH1b/Dv5PafjksOORSZOwsRYHPawJGCGJINWsQDTyeiuF Mo6Dxg4SgNF1AYS8P/PuUpvm/ogcX+9gmRdO9Q8OBZdxDTgMdMg/CyrqMAD1YJQFSYM0mrY5pE iBidDRtsZtTpVabjTSuqluiMAI0mgj1n2EqWswIWsoOtaxpvMj0iIOtcYlhQjNv5z3JRzHrwnx dh4= X-IronPort-AV: E=Sophos;i="5.83,315,1616486400"; d="diff'?scan'208";a="63070051" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 01 Jul 2021 09:09:02 -0800 IronPort-SDR: h66mOBHCF3wKGcjfkAcokbjW3INvrw3unuVl1wUbkFM591h4VzjF/FU+jHa3Kg7lN6QPxLlcKV goub84tvXJAOKQOq3iYwJRQM4KtH5hOfbXTu8F05LvTj7Lz442JPcYmWs3FjOJEKJwiXqLR0vE TLXeTFHj0oQ/OwF0x9QmEcGz37g1dV1UDL+ZgCoU+AqPP63ArMPic1H9zmRi7F89HpbaKZ6/kn nRM3u2ggbfAa7rXxtcmF/Iqdir56jBvXiwRTIileFilQoO2qefti3Yvr4ZRHVnx2iXD18K5aUh 970= To: gcc-patches , fortran , Paul Richard Thomas From: Tobias Burnus Subject: [Patch] Fortran: Fix bind(C) character length checks CC: Sandra Loosemore Message-ID: <602673f7-ea8e-9e71-23cb-4989ed23e079@codesourcery.com> Date: Thu, 1 Jul 2021 19:08:55 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.11.0 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------D1174B79EA195C494F6E97FB" Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-11.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) 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-List-Received-Date: Thu, 01 Jul 2021 17:09:09 -0000 --------------D1174B79EA195C494F6E97FB Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: quoted-printable Hi all, this patch came up when discussing Sandra's TS29113 patch internally. There is presumably also some overlap with Jos=C3=A9's patches. This patch tries to rectify the BIND(C) CHARACTER handling on the diagnostic side, only. That is: what to accept and what to reject for which Fortran standard. The rules are: * [F2003-F2018] Interoperable is character(len=3D1) =E2=86=92 F2018, 18.3.1 Interoperability of intrinsic types (General, unchanged) * Fortran 2008: In some cases, const-length chars are permitted as well: =E2=86=92 F2018, 18.3.4 Interoperability of scalar variables =E2=86=92 F2018, 18.3.5 Interoperability of array variables =E2=86=92 F2018, 18.3.6 Interoperability of procedures and procedure in= terfaces [=3D F2008, 15.3.{4,5,6} For global vars with bind(C), 18.3.4 + 18.3.5 applies directly (TODO: Add s= upport, not in this patch) For passed-by ref dummy arguments, 18.3.4 + 18.3.5 are referenced in - F2008: R1229 proc-language-binding-spec is language-binding-spec C1255 (R1229) - F2018, F2018, C1554 While it is not very clearly spelt out, I regard 'char parm[4]' interoperable with 'character(len=3D4) :: a', 'character(len=3D2) :: b(2)' and 'character(len=3D1) :: c(4)' for both global variables and for dummy arguments. * Fortran 2018/TS29113: Uses additionally CFI array descriptor - allocatable, pointer: must be len=3D: - nonallocatable/nonpointer: len=3D* =E2=86=92 implies array descriptor = also for assumed-size/explicit-size/scalar arguments. - All which all passed by an array descriptor already without further restrictions: assumed-shape, assumed-rank, i.e. len=3D seems to be also fine =E2=86=92 18.3.6 under item (5) bullet point 2 and 3 plus (6). I hope I got the conditions right. I also fixed an issue with character(len=3D5) :: str =E2=80=93 the code in trans-expr.c did crash for scalars (decl.c did not check any constraints for arrays). I believe the condition is wrong and for len=3D no descriptor is used. Any comments, remarks? OK for mainline? Tobias PS: To do are global variables, the implementation of the sorries; PPS: At other places like with VALUE or for function return values, Fortran still requires len=3D1 with Bind(C). ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 M=C3=BCnchen R= egistergericht M=C3=BCnchen HRB 106955, Gesch=C3=A4ftsf=C3=BChrer: Thomas H= eurung, Frank Th=C3=BCrauf --------------D1174B79EA195C494F6E97FB Content-Type: text/x-patch; charset="UTF-8"; name="bind-c-char.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="bind-c-char.diff" Fortran: Fix bind(C) character length checks gcc/fortran/ChangeLog: * decl.c (gfc_verify_c_interop_param): Update for F2008 + F2018 changes; reject unsupported bits with 'Error: Sorry,'. * trans-expr.c (gfc_conv_procedure_call): Fix condition to For using CFI descriptor with characters. gcc/testsuite/ChangeLog: * gfortran.dg/iso_c_binding_char_1.f90: Update dg-error. * gfortran.dg/pr32599.f03: Use -std=-f2003 + update comment. * gfortran.dg/bind_c_char_10.f90: New test. * gfortran.dg/bind_c_char_6.f90: New test. * gfortran.dg/bind_c_char_7.f90: New test. * gfortran.dg/bind_c_char_8.f90: New test. * gfortran.dg/bind_c_char_9.f90: New test. gcc/fortran/decl.c | 107 ++++- gcc/fortran/trans-expr.c | 18 +- gcc/testsuite/gfortran.dg/bind_c_char_10.f90 | 480 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/bind_c_char_6.f90 | 262 +++++++++++ gcc/testsuite/gfortran.dg/bind_c_char_7.f90 | 261 +++++++++++ gcc/testsuite/gfortran.dg/bind_c_char_8.f90 | 249 +++++++++++ gcc/testsuite/gfortran.dg/bind_c_char_9.f90 | 188 ++++++++ gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 | 2 +- gcc/testsuite/gfortran.dg/pr32599.f03 | 8 +- 9 files changed, 1551 insertions(+), 24 deletions(-) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 413c7a75e0c..4a9f74306ff 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1552,20 +1552,109 @@ gfc_verify_c_interop_param (gfc_symbol *sym) } /* Character strings are only C interoperable if they have a - length of 1. */ - if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension) + length of 1. However, as argument they are either iteroperable + when passed as descriptor (which requires len=: or len=*) or + when having a constant length or are always passed by + descriptor. */ + if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.u.cl; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (cl->length->value.integer, 1) != 0) + + if (sym->attr.allocatable || sym->attr.pointer) { - gfc_error ("Character argument %qs at %L " - "must be length 1 because " - "procedure %qs is BIND(C)", - sym->name, &sym->declared_at, - sym->ns->proc_name->name); + /* F2018, 18.3.6 (6). */ + if (!sym->ts.deferred) + { + gfc_error ("Allocatable and pointer character dummy " + "argument %qs at %L must have deferred length " + "as procedure %qs is BIND(C)", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + retval = false; + } + else if (!gfc_notify_std (GFC_STD_F2018, + "Deferred-length character dummy " + "argument %qs at %L of procedure " + "%qs with BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + else if (!sym->attr.dimension) + { + /* FIXME: Use CFI array descriptor for scalars. */ + gfc_error ("Sorry, deferred-length scalar character dummy " + "argument %qs at %L of procedure %qs with " + "BIND(C) not yet supported", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + retval = false; + } + } + else if (sym->attr.value + && (!cl || !cl->length + || cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0)) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of length 1 as it has the VALUE attribute", + sym->name, &sym->declared_at); retval = false; } + else if (!cl || !cl->length) + { + /* Assumed length; F2018, 18.3.6 (5)(2). + Uses the CFI array descriptor. */ + if (!gfc_notify_std (GFC_STD_F2018, + "Assumed-length character dummy argument " + "%qs at %L of procedure %qs with BIND(C) " + "attribute", sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + else if (!sym->attr.dimension + || sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_EXPLICIT) + { + /* FIXME: Valid - should use the CFI array descriptor, but + not yet handled for scalars and assumed-/explicit-size + arrays. */ + gfc_error ("Sorry, character dummy argument %qs at %L " + "with assumed length is not yet supported for " + "procedure %qs with BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + } + else if (cl->length->expr_type != EXPR_CONSTANT) + { + /* F2018, 18.3.6, (5), item 4. */ + if (!sym->attr.dimension + || sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_EXPLICIT) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of constant length or assumed length, " + "unless it has assumed-shape or assumed-rank, " + "as procedure %qs has the BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + else if (!gfc_notify_std (GFC_STD_F2018, + "Character dummy argument %qs at %L" + " with nonconstant length as " + "procedure %qs is BIND(C)", + sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + } + else if (mpz_cmp_si (cl->length->value.integer, 1) != 0 + && !gfc_notify_std (GFC_STD_F2008, + "Character dummy argument %qs at %L " + "with length greater than 1 for " + "procedure %qs with BIND(C) " + "attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; } /* We have to make sure that any param to a bind(c) routine does diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index de406ad2e8f..2e0874b3b55 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5756,18 +5756,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, arg = arg->next, formal = formal ? formal->next : NULL, ++argc) { bool finalized = false; - bool non_unity_length_string = false; + bool assumed_length_string = false; tree derived_array = NULL_TREE; e = arg->expr; fsym = formal ? formal->sym : NULL; parm_kind = MISSING; - if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl - && (!fsym->ts.u.cl->length - || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0)) - non_unity_length_string = true; + if (fsym && fsym->ts.type == BT_CHARACTER + && (!fsym->ts.u.cl || !fsym->ts.u.cl->length)) + assumed_length_string = true; /* If the procedure requires an explicit interface, the actual argument is passed according to the corresponding formal @@ -6001,8 +5999,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (sym->attr.is_bind_c && e && (is_CFI_desc (fsym, NULL) - || non_unity_length_string)) - /* Implement F2018, C.12.6.1: paragraph (2). */ + || assumed_length_string)) + /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); else if (fsym && fsym->attr.value) @@ -6446,8 +6444,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } if (sym->attr.is_bind_c && e - && (is_CFI_desc (fsym, NULL) || non_unity_length_string)) - /* Implement F2018, C.12.6.1: paragraph (2). */ + && (is_CFI_desc (fsym, NULL) || assumed_length_string)) + /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); else if (e->expr_type == EXPR_VARIABLE diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 new file mode 100644 index 00000000000..35958515d38 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 @@ -0,0 +1,480 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! F2018 - examples with array descriptor + +module m + use iso_c_binding, only: c_char + implicit none (type, external) + +contains + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine as1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(:) + if (size(x1) /= 6) stop + if (len(x1) /= 1) stop + if (any (x1 /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop 1 + x1 = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] +end + +subroutine as2 (x2) bind(C) + character(kind=c_char, len=2) :: x2(:) + if (size(x2) /= 6) stop + if (len(x2) /= 2) stop + if (any (x2 /= ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'])) stop + x2 = ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'] +end + +subroutine as3 (xn, n) bind(C) + integer :: n + character(kind=c_char, len=n) :: xn(:) + if (size(xn) /= 6) stop + if (len(xn) /= 5) stop + if (any (xn /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xn = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] +end + +subroutine as4 (xstar) bind(C) + character(kind=c_char, len=*) :: xstar(:) + if (size(xstar) /= 6) stop + if (len(xstar) /= 5) stop + if (any (xstar /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xstar = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] +end + +! Assumed-rank array, nonallocatable/nonpointer + +subroutine ar1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(..) + if (size(x1) /= 6) stop + if (len(x1) /= 1) stop + select rank(x1) + rank(1) + if (any (x1 /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop + x1 = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] + rank default + stop + end select +end + +subroutine ar2 (x2) bind(C) + character(kind=c_char, len=2) :: x2(..) + if (size(x2) /= 6) stop + if (len(x2) /= 2) stop + select rank(x2) + rank(1) + if (any (x2 /= ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'])) stop + x2 = ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'] + rank default + stop + end select +end + +subroutine ar3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(..) + if (size(xn) /= 6) stop + if (len(xn) /= 5) stop + select rank(xn) + rank(1) + if (any (xn /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xn = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] + rank default + stop + end select +end + +subroutine ar4 (xstar) bind(C) + character(kind=c_char, len=*) :: xstar(..) + if (size(xstar) /= 6) stop + if (len(xstar) /= 5) stop + select rank(xstar) + rank(1) + if (any (xstar /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xstar = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] + rank default + stop + end select +end + +! ALLOCATABLE + +! Assumed-shape array, allocatable + +subroutine a5a (xcolon) bind(C) + character(kind=c_char, len=:), allocatable :: xcolon(:) + if (.not. allocated (xcolon)) stop + if (size(xcolon) /= 6) stop + if (len(xcolon) /= 5) stop + if (any (xcolon /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xcolon = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] +end + +! Assumed-rank array, allocatable + +subroutine a5ar (xcolon) bind(C) + character(kind=c_char, len=:), allocatable :: xcolon(..) + if (.not. allocated (xcolon)) stop + if (size(xcolon) /= 6) stop + if (len(xcolon) /= 5) stop + select rank(xcolon) + rank(1) + if (any (xcolon /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xcolon = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] + rank default + stop + end select +end + +! POINTER +! Assumed-shape array, pointer + +subroutine a5p (xcolon) bind(C) + character(kind=c_char, len=:), pointer :: xcolon(:) + if (.not. associated (xcolon)) stop + if (size(xcolon) /= 6) stop + if (len(xcolon) /= 5) stop + if (any (xcolon /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xcolon = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] +end + +! Assumed-rank array, pointer + +subroutine a5pr (xcolon) bind(C) + character(kind=c_char, len=:), pointer :: xcolon(..) + if (.not. associated (xcolon)) stop + if (size(xcolon) /= 6) stop + if (len(xcolon) /= 5) stop + select rank(xcolon) + rank(1) + if (any (xcolon /= ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'])) stop + xcolon = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] + rank default + stop + end select +end +end module m + +program main + use m + implicit none (type, external) + character(kind=c_char, len=1) :: str1a6(6) + character(kind=c_char, len=2) :: str2a6(6) + character(kind=c_char, len=5) :: str5a6(6) + + character(kind=c_char, len=:), allocatable :: astr5a6(:) + character(kind=c_char, len=:), pointer :: pstr5a6(:) + + allocate (character(kind=c_char, len=5) :: astr5a6(6), pstr5a6(6)) + + ! assumed shape - with array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call as1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop + str2a6 = ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'] + call as2 (str2a6) + if (any (str2a6 /= ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'])) stop + + str5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call as3 (str5a6, 5) + if (any (str5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + str5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call as4 (str5a6) + if (any (str5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + ! assumed rank - with array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call ar1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop + str2a6 = ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'] + call ar2 (str2a6) + if (any (str2a6 /= ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'])) stop + + str5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call ar3 (str5a6, 5) + if (any (str5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + + str5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call ar4 (str5a6) + if (any (str5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + ! allocatable - with array descriptor + astr5a6(:) = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call a5a (astr5a6) + if (any (astr5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + astr5a6(:) = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call a5ar (astr5a6) + if (any (astr5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + + ! pointer - with array descriptor + pstr5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call a5p (pstr5a6) + if (any (pstr5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + + pstr5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call a5pr (pstr5a6) + if (any (pstr5a6 /= ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'])) stop + deallocate (astr5a6, pstr5a6) +end + +! All arguments shall use array descriptors +! { dg-final { scan-tree-dump-times "void as1 \\(struct array01_character\\(kind=1\\) & restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as2 \\(struct array01_character\\(kind=1\\) & restrict x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as4 \\(struct array01_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void as3 \\(struct array01_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n) +! { dg-final { scan-tree-dump-times "void ar1 \\(struct array15_character\\(kind=1\\) & restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar2 \\(struct array15_character\\(kind=1\\) & restrict x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ar3 \\(struct array15_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n) +! { dg-final { scan-tree-dump-times "void ar4 \\(struct array15_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5a \\(struct array01_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5ar \\(struct array15_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5p \\(struct array01_character\\(kind=1\\) & xcolon\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void a5pr \\(struct array15_character\\(kind=1\\) & xcolon\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_6.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_6.f90 new file mode 100644 index 00000000000..aa01dc8d54f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_char_6.f90 @@ -0,0 +1,262 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2003 -fimplicit-none" } + +! F2003 only permits length=1 character dummy args + +! Scalar, nonallocatable/nonpointer + +subroutine s1 (x1) bind(C) + character(len=1) :: x1 +end + +subroutine s2 (x2) bind(C) ! { dg-error "Fortran 2008: Character dummy argument 'x2' at .1. with length greater than 1 for procedure 's2' with BIND\\(C\\) attribute" } + character(len=2) :: x2 +end + +subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 's3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn +end + +subroutine s4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 's4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar +end + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine as1 (x1) bind(C) ! { dg-error "Fortran 2018: Assumed-shape array 'x1' at .1. as dummy argument to the BIND\\(C\\) procedure 'as1' at .2." } + character(len=1) :: x1(:) +end + +subroutine as2 (x2) bind(C) ! { dg-error "Fortran 2008: Character dummy argument 'x2' at .1. with length greater than 1 for procedure 'as2' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Assumed-shape array 'x2' at .1. as dummy argument to the BIND\\(C\\) procedure 'as2' at .2." "" { target *-*-* } .-1 } + character(len=2) :: x2(:,:) +end + +subroutine as3 (xn, n) bind(C) ! { dg-error "Fortran 2018: Character dummy argument 'xn' at .1. with nonconstant length as procedure 'as3' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Assumed-shape array 'xn' at .1. as dummy argument to the BIND\\(C\\) procedure 'as3' at .2." "" { target *-*-* } .-1 } + integer :: n + character(len=n) :: xn(:,:,:) +end + +subroutine as4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'as4' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Assumed-shape array 'xstar' at .1. as dummy argument to the BIND\\(C\\) procedure 'as4' at .2." "" { target *-*-* } .-1 } + character(len=*) :: xstar(:,:,:,:) +end + +! Assumed-rank array, nonallocatable/nonpointer + +subroutine ar1 (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1) :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar2 (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2) :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar3 (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n) :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar4 (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*) :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(len=1) :: x1(*) +end + +subroutine az2 (x2) bind(C) ! { dg-error "Fortran 2008: Character dummy argument 'x2' at .1. with length greater than 1 for procedure 'az2' with BIND\\(C\\) attribute" } + character(len=2) :: x2(*) +end + +subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'az3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(*) +end + +subroutine az4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'az4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(*) +end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(len=1) :: x1(5) +end + +subroutine ae2 (x2) bind(C) ! { dg-error "Fortran 2008: Character dummy argument 'x2' at .1. with length greater than 1 for procedure 'ae2' with BIND\\(C\\) attribute" } + character(len=2) :: x2(7) +end + +subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'ae3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(9) +end + +subroutine ae4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'ae4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(3) +end + +! ALLOCATABLE +! Scalar, allocatable + +subroutine s1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with ALLOCATABLE attribute in procedure 's1a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), allocatable :: x1 +end + +subroutine s2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with ALLOCATABLE attribute in procedure 's2a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), allocatable :: x2 +end + +subroutine s3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with ALLOCATABLE attribute in procedure 's3a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), allocatable :: xn +end + +subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with ALLOCATABLE attribute in procedure 's4a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), allocatable :: xstar +end + +subroutine s5a (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 's5a' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with ALLOCATABLE attribute in procedure 's5a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), allocatable :: xcolon +end + +! Assumed-shape array, allocatable + +subroutine a1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with ALLOCATABLE attribute in procedure 'a1a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), allocatable :: x1(:) +end + +subroutine a2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with ALLOCATABLE attribute in procedure 'a2a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), allocatable :: x2(:,:) +end + +subroutine a3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with ALLOCATABLE attribute in procedure 'a3a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), allocatable :: xn(:,:,:) +end + +subroutine a4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with ALLOCATABLE attribute in procedure 'a4a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), allocatable :: xstar(:,:,:,:) +end + +subroutine a5a (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 'a5a' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with ALLOCATABLE attribute in procedure 'a5a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), allocatable :: xcolon(:) +end + +! Assumed-rank array, allocatable + +subroutine a1ar (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1), allocatable :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a2ar (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2), allocatable :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a3ar (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n), allocatable :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a4ar (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*), allocatable :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a5ar (xcolon) bind(C) ! { dg-error "Symbol 'xcolon' at .1. has no IMPLICIT type" } + character(len=:), allocatable :: xcolon(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +! POINTER +! Scalar, pointer + +subroutine s1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with POINTER attribute in procedure 's1p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), pointer :: x1 +end + +subroutine s2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with POINTER attribute in procedure 's2p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), pointer :: x2 +end + +subroutine s3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with POINTER attribute in procedure 's3p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), pointer :: xn +end + +subroutine s4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with POINTER attribute in procedure 's4p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), pointer :: xstar +end + +subroutine s5p (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 's5p' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with POINTER attribute in procedure 's5p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), pointer :: xcolon +end + +! Assumed-shape array, pointer + +subroutine a1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with POINTER attribute in procedure 'a1p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), pointer :: x1(:) +end + +subroutine a2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with POINTER attribute in procedure 'a2p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), pointer :: x2(:,:) +end + +subroutine a3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with POINTER attribute in procedure 'a3p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), pointer :: xn(:,:,:) +end + +subroutine a4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with POINTER attribute in procedure 'a4p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), pointer :: xstar(:,:,:,:) +end + +subroutine a5p (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 'a5p' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with POINTER attribute in procedure 'a5p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), pointer :: xcolon(:) +end + +! Assumed-rank array, pointer + +subroutine a1pr (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1), pointer :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a2pr (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2), pointer :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a3pr (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n), pointer :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a4pr (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*), pointer :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a5pr (xcolon) bind(C) ! { dg-error "Symbol 'xcolon' at .1. has no IMPLICIT type" } + character(len=:), pointer :: xcolon(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_7.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_7.f90 new file mode 100644 index 00000000000..fffdf18129f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_char_7.f90 @@ -0,0 +1,261 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2008 -fimplicit-none" } + +! F2008 permits constant character lengths for dummy arguments + +! Scalar, nonallocatable/nonpointer + +subroutine s1 (x1) bind(C) + character(len=1) :: x1 +end + +subroutine s2 (x2) bind(C) + character(len=2) :: x2 +end + +subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 's3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn +end + +subroutine s4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 's4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar +end + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine as1 (x1) bind(C) ! { dg-error "Fortran 2018: Assumed-shape array 'x1' at .1. as dummy argument to the BIND\\(C\\) procedure 'as1' at .2." } + character(len=1) :: x1(:) +end + +subroutine as2 (x2) bind(C) ! { dg-error "Fortran 2018: Assumed-shape array 'x2' at .1. as dummy argument to the BIND\\(C\\) procedure 'as2' at .2." } + character(len=2) :: x2(:,:) +end + +subroutine as3 (xn, n) bind(C) ! { dg-error "Fortran 2018: Character dummy argument 'xn' at .1. with nonconstant length as procedure 'as3' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Assumed-shape array 'xn' at .1. as dummy argument to the BIND\\(C\\) procedure 'as3' at .2." "" { target *-*-* } .-1 } + integer :: n + character(len=n) :: xn(:,:,:) +end + +subroutine as4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'as4' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Assumed-shape array 'xstar' at .1. as dummy argument to the BIND\\(C\\) procedure 'as4' at .2." "" { target *-*-* } .-1 } + character(len=*) :: xstar(:,:,:,:) +end + +! Assumed-rank array, nonallocatable/nonpointer + +subroutine ar1 (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1) :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar2 (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2) :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar3 (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n) :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine ar4 (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*) :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(len=1) :: x1(*) +end + +subroutine az2 (x2) bind(C) + character(len=2) :: x2(*) +end + +subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'az3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(*) +end + +subroutine az4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'az4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(*) +end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(len=1) :: x1(5) +end + +subroutine ae2 (x2) bind(C) + character(len=2) :: x2(7) +end + +subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'ae3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(9) +end + +subroutine ae4 (xstar) bind(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'xstar' at .1. of procedure 'ae4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(3) +end + +! ALLOCATABLE +! Scalar, allocatable + +subroutine s1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with ALLOCATABLE attribute in procedure 's1a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), allocatable :: x1 +end + +subroutine s2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with ALLOCATABLE attribute in procedure 's2a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), allocatable :: x2 +end + +subroutine s3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with ALLOCATABLE attribute in procedure 's3a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), allocatable :: xn +end + +subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with ALLOCATABLE attribute in procedure 's4a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), allocatable :: xstar +end + +subroutine s5a (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 's5a' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with ALLOCATABLE attribute in procedure 's5a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), allocatable :: xcolon +end + +! Assumed-shape array, allocatable + +subroutine a1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with ALLOCATABLE attribute in procedure 'a1a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), allocatable :: x1(:) +end + +subroutine a2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with ALLOCATABLE attribute in procedure 'a2a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), allocatable :: x2(:,:) +end + +subroutine a3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with ALLOCATABLE attribute in procedure 'a3a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), allocatable :: xn(:,:,:) +end + +subroutine a4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4a' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with ALLOCATABLE attribute in procedure 'a4a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), allocatable :: xstar(:,:,:,:) +end + +subroutine a5a (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 'a5a' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with ALLOCATABLE attribute in procedure 'a5a' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), allocatable :: xcolon(:) +end + +! Assumed-rank array, allocatable + +subroutine a1ar (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1), allocatable :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a2ar (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2), allocatable :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a3ar (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n), allocatable :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a4ar (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*), allocatable :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a5ar (xcolon) bind(C) ! { dg-error "Symbol 'xcolon' at .1. has no IMPLICIT type" } + character(len=:), allocatable :: xcolon(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +! POINTER +! Scalar, pointer + +subroutine s1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with POINTER attribute in procedure 's1p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), pointer :: x1 +end + +subroutine s2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with POINTER attribute in procedure 's2p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), pointer :: x2 +end + +subroutine s3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with POINTER attribute in procedure 's3p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), pointer :: xn +end + +subroutine s4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with POINTER attribute in procedure 's4p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), pointer :: xstar +end + +subroutine s5p (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 's5p' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with POINTER attribute in procedure 's5p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), pointer :: xcolon +end + +! Assumed-shape array, pointer + +subroutine a1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x1' at .1. with POINTER attribute in procedure 'a1p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=1), pointer :: x1(:) +end + +subroutine a2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'x2' at .1. with POINTER attribute in procedure 'a2p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=2), pointer :: x2(:,:) +end + +subroutine a3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xn' at .1. with POINTER attribute in procedure 'a3p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + integer :: n + character(len=n), pointer :: xn(:,:,:) +end + +subroutine a4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4p' is BIND\\(C\\)" } + ! { dg-error "Fortran 2018: Variable 'xstar' at .1. with POINTER attribute in procedure 'a4p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=*), pointer :: xstar(:,:,:,:) +end + +subroutine a5p (xcolon) bind(C) ! { dg-error "Fortran 2018: Deferred-length character dummy argument 'xcolon' at .1. of procedure 'a5p' with BIND\\(C\\) attribute" } + ! { dg-error "Fortran 2018: Variable 'xcolon' at .1. with POINTER attribute in procedure 'a5p' with BIND\\(C\\)" "" { target *-*-* } .-1 } + character(len=:), pointer :: xcolon(:) +end + +! Assumed-rank array, pointer + +subroutine a1pr (x1) bind(C) ! { dg-error "Symbol 'x1' at .1. has no IMPLICIT type" } + character(len=1), pointer :: x1(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a2pr (x2) bind(C) ! { dg-error "Symbol 'x2' at .1. has no IMPLICIT type" } + character(len=2), pointer :: x2(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a3pr (xn, n) bind(C) ! { dg-error "Symbol 'xn' at .1. has no IMPLICIT type" } + integer :: n + character(len=n), pointer :: xn(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a4pr (xstar) bind(C) ! { dg-error "Symbol 'xstar' at .1. has no IMPLICIT type" } + character(len=*), pointer :: xstar(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end + +subroutine a5pr (xcolon) bind(C) ! { dg-error "Symbol 'xcolon' at .1. has no IMPLICIT type" } + character(len=:), pointer :: xcolon(..) ! { dg-error "Fortran 2018: Assumed-rank array at .1." } +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 new file mode 100644 index 00000000000..86a9b612c02 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 @@ -0,0 +1,249 @@ +! { dg-do compile } +! { dg-additional-options "-fimplicit-none" } + +! F2018 only permittes len=*, len=: or len= as dummy argument +! but not len= +! Additionally, for allocatable/pointer, len=: is required. + +! Scalar, nonallocatable/nonpointer + +subroutine val_s1(x1) bind(C) + character(len=1), value :: x1 +end + +subroutine val_s2(x2) bind(C) ! { dg-error "Character dummy argument 'x2' at .1. must be of length 1 as it has the VALUE attribute" } + character(len=2), value :: x2 +end + +subroutine s1 (x1) bind(C) + character(len=1) :: x1 +end + +subroutine s2 (x2) bind(C) + character(len=2) :: x2 +end + +subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 's3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn +end + +subroutine s4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 's4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar +end + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine as1 (x1) bind(C) + character(len=1) :: x1(:) +end + +subroutine as2 (x2) bind(C) + character(len=2) :: x2(:,:) +end + +subroutine as3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(:,:,:) +end + +subroutine as4 (xstar) bind(C) + character(len=*) :: xstar(:,:,:,:) +end + +! Assumed-rank array, nonallocatable/nonpointer + +subroutine ar1 (x1) bind(C) + character(len=1) :: x1(..) +end + +subroutine ar2 (x2) bind(C) + character(len=2) :: x2(..) +end + +subroutine ar3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(..) +end + +subroutine ar4 (xstar) bind(C) + character(len=*) :: xstar(..) +end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(len=1) :: x1(*) +end + +subroutine az2 (x2) bind(C) + character(len=2) :: x2(*) +end + +subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'az3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(*) +end + +subroutine az4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'az4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(*) +end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(len=1) :: x1(5) +end + +subroutine ae2 (x2) bind(C) + character(len=2) :: x2(7) +end + +subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length or assumed length, unless it has assumed-shape or assumed-rank, as procedure 'ae3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(9) +end + +subroutine ae4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'ae4' with BIND\\(C\\) attribute" } + character(len=*) :: xstar(3) +end + +! ALLOCATABLE +! Scalar, allocatable + +subroutine s1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1a' is BIND\\(C\\)" } + character(len=1), allocatable :: x1 +end + +subroutine s2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2a' is BIND\\(C\\)" } + character(len=2), allocatable :: x2 +end + +subroutine s3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3a' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn +end + +subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4a' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar +end + +subroutine s5a (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5a' with BIND\\(C\\) not yet supported" } + character(len=:), allocatable :: xcolon +end + +! Assumed-shape array, allocatable + +subroutine a1a (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1a' is BIND\\(C\\)" } + character(len=1), allocatable :: x1(:) +end + +subroutine a2a (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2a' is BIND\\(C\\)" } + character(len=2), allocatable :: x2(:,:) +end + +subroutine a3a (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3a' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn(:,:,:) +end + +subroutine a4a (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4a' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar(:,:,:,:) +end + +subroutine a5a (xcolon) bind(C) + character(len=:), allocatable :: xcolon(:) +end + +! Assumed-rank array, allocatable + +subroutine a1ar (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1ar' is BIND\\(C\\)" } + character(len=1), allocatable :: x1(..) +end + +subroutine a2ar (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2ar' is BIND\\(C\\)" } + character(len=2), allocatable :: x2(..) +end + +subroutine a3ar (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3ar' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn(..) +end + +subroutine a4ar (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4ar' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar(..) +end + +subroutine a5ar (xcolon) bind(C) + character(len=:), allocatable :: xcolon(..) +end + +! POINTER +! Scalar, pointer + +subroutine s1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1p' is BIND\\(C\\)" } + character(len=1), pointer :: x1 +end + +subroutine s2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2p' is BIND\\(C\\)" } + character(len=2), pointer :: x2 +end + +subroutine s3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3p' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn +end + +subroutine s4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4p' is BIND\\(C\\)" } + character(len=*), pointer :: xstar +end + +subroutine s5p (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5p' with BIND\\(C\\) not yet supported" } + character(len=:), pointer :: xcolon +end + +! Assumed-shape array, pointer + +subroutine a1p (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1p' is BIND\\(C\\)" } + character(len=1), pointer :: x1(:) +end + +subroutine a2p (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2p' is BIND\\(C\\)" } + character(len=2), pointer :: x2(:,:) +end + +subroutine a3p (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3p' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn(:,:,:) +end + +subroutine a4p (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4p' is BIND\\(C\\)" } + character(len=*), pointer :: xstar(:,:,:,:) +end + +subroutine a5p (xcolon) bind(C) + character(len=:), pointer :: xcolon(:) +end + +! Assumed-rank array, pointer + +subroutine a1pr (x1) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1pr' is BIND\\(C\\)" } + character(len=1), pointer :: x1(..) +end + +subroutine a2pr (x2) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2pr' is BIND\\(C\\)" } + character(len=2), pointer :: x2(..) +end + +subroutine a3pr (xn, n) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3pr' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn(..) +end + +subroutine a4pr (xstar) bind(C) ! { dg-error "Allocatable and pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4pr' is BIND\\(C\\)" } + character(len=*), pointer :: xstar(..) +end + +subroutine a5pr (xcolon) bind(C) + character(len=:), pointer :: xcolon(..) +end diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_9.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_9.f90 new file mode 100644 index 00000000000..d31862c89e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_char_9.f90 @@ -0,0 +1,188 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! F2018 - examples without array descriptor + + +module m + use iso_c_binding, only: c_char + implicit none (type, external) + +contains + +! Scalar, nonallocatable/nonpointer +subroutine s1 (x1) bind(C) + character(kind=c_char, len=1) :: x1 + if (len (x1) /= 1) stop + if (x1 /= 'Z') stop + x1 = 'A' +end + +subroutine s2 (x2) bind(C) + character(kind=c_char, len=2) :: x2 + if (len (x2) /= 2) stop + if (x2 /= '42') stop + x2 = '64' +end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(*) + if (len(x1) /= 1) stop + if (any (x1(:6) /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop 1 + x1(:6) = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] +end + +subroutine az2 (x2) bind(C) + character(kind=c_char, len=2) :: x2(*) + if (len(x2) /= 2) stop + if (any (x2(:6) /= ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'])) stop + x2(:6) = ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'] +end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(6) + if (size(x1) /= 6) stop + if (len(x1) /= 1) stop + if (any (x1 /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop 1 + x1 = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] +end + +subroutine ae2 (x2) bind(C) + character(kind=c_char, len=2) :: x2(6) + if (size(x2) /= 6) stop + if (len(x2) /= 2) stop + if (any (x2 /= ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'])) stop + x2 = ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'] +end + +end module m + +program main + use m + implicit none (type, external) + character(kind=c_char, len=1) :: str1 + character(kind=c_char, len=2) :: str2 + + character(kind=c_char, len=1) :: str1a6(6) + character(kind=c_char, len=2) :: str2a6(6) + + ! Scalar - no array descriptor + + str1 = 'Z' + call s1 (str1) + if (str1 /= 'A') stop + + str2 = '42' + call s2 (str2) + if (str2 /= '64') stop + + ! assumed size - without array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call az1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop + str2a6 = ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'] + call az2 (str2a6) + if (any (str2a6 /= ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'])) stop + ! explicit size - without array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call ae1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop + str2a6 = ['ab', & + 'fd', & + 'D4', & + '54', & + 'ga', & + 'hg'] + call ae2 (str2a6) + if (any (str2a6 /= ['ab', & + 'hd', & + 'fj', & + 'a4', & + '4a', & + 'hf'])) stop +end + +! All argument shall be passed without descriptor +! { dg-final { scan-tree-dump-not "dtype" "original" } } +! { dg-final { scan-tree-dump-times "void s1 \\(character\\(kind=1\\)\\\[1:1\\\] & restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void s2 \\(character\\(kind=1\\)\\\[1:2\\\] & restrict x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void az1 \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void az2 \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:2\\\] \\* restrict x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ae1 \\(character\\(kind=1\\)\\\[6\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "void ae2 \\(character\\(kind=1\\)\\\[6\\\]\\\[1:2\\\] \\* restrict x2\\)" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 index ebf9a248dac..abe5cb71bfc 100644 --- a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 +++ b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 @@ -4,7 +4,7 @@ ! ! Contributed by Thomas Koenig ! -subroutine bar(c,d) BIND(C) ! { dg-error "must be length 1" } +subroutine bar(c,d) BIND(C) ! { dg-error "character dummy argument 'c' at .1. with assumed length is not yet supported for procedure 'bar' with BIND\\(C\\) attribute" } character (len=*) c character (len=2) d end diff --git a/gcc/testsuite/gfortran.dg/pr32599.f03 b/gcc/testsuite/gfortran.dg/pr32599.f03 index 297b75a7444..bf9bd8c1d68 100644 --- a/gcc/testsuite/gfortran.dg/pr32599.f03 +++ b/gcc/testsuite/gfortran.dg/pr32599.f03 @@ -1,20 +1,20 @@ ! { dg-do compile } -! { dg-options "-std=f2008" } +! { dg-options "-std=f2003" } ! ! PR fortran/32599 ! Verifies that character string arguments to a bind(c) procedure have length -! 1, or no len is specified. Note that the C interop extensions in F2018 allow +! 1, or no len is specified. Note that the C interop extensions in F2008 allow ! string arguments of length greater than one to be passed to a C descriptor. ! module pr32599 interface - subroutine destroy(path) BIND(C) ! { dg-error "must be length 1" } + subroutine destroy(path) BIND(C) ! { dg-error "Fortran 2018: Assumed-length character dummy argument 'path' at .1. of procedure .destroy. with BIND\\(C\\) attribute" } use iso_c_binding implicit none character(len=*,kind=c_char), intent(IN) :: path end subroutine destroy - subroutine create(path) BIND(C) ! { dg-error "must be length 1" } + subroutine create(path) BIND(C) ! { dg-error "Fortran 2008: Character dummy argument 'path' at .1. with length greater than 1 for procedure 'create' with BIND\\(C\\) attribute" } use iso_c_binding implicit none character(len=5,kind=c_char), intent(IN) :: path --------------D1174B79EA195C494F6E97FB--