From patchwork Thu Jul 1 17:08:55 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1499667 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=) 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 4GG4Sk6lsdz9sT6 for ; Fri, 2 Jul 2021 03:09:25 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EF2C4383D803 for ; Thu, 1 Jul 2021 17:09:22 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org 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 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-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: , Cc: Sandra Loosemore Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Hi all, this patch came up when discussing Sandra's TS29113 patch internally. There is presumably also some overlap with José'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=1) → F2018, 18.3.1 Interoperability of intrinsic types (General, unchanged) * Fortran 2008: In some cases, const-length chars are permitted as well: → F2018, 18.3.4 Interoperability of scalar variables → F2018, 18.3.5 Interoperability of array variables → F2018, 18.3.6 Interoperability of procedures and procedure interfaces [= F2008, 15.3.{4,5,6} For global vars with bind(C), 18.3.4 + 18.3.5 applies directly (TODO: Add support, 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=4) :: a', 'character(len=2) :: b(2)' and 'character(len=1) :: c(4)' for both global variables and for dummy arguments. * Fortran 2018/TS29113: Uses additionally CFI array descriptor - allocatable, pointer: must be len=: - nonallocatable/nonpointer: len=* → 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= seems to be also fine → 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=5) :: str – 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= 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=1 with Bind(C). ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf 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