From patchwork Thu Jun 22 20:23:24 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 111799 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:994d:0:b0:3d9:f83d:47d9 with SMTP id k13csp5323943vqr; Thu, 22 Jun 2023 13:24:12 -0700 (PDT) X-Google-Smtp-Source: ACHHUZ4N04bfiqQwwnpHXliwc/5D/oh2oHTNP4zFfT+3imYjgRNkaXoQXxI4M93+P8oXCB6rGGO/ X-Received: by 2002:aa7:c602:0:b0:51b:df18:cbe5 with SMTP id h2-20020aa7c602000000b0051bdf18cbe5mr3781075edq.38.1687465451592; Thu, 22 Jun 2023 13:24:11 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1687465451; cv=none; d=google.com; s=arc-20160816; b=YSKEdPnDbkIReHDiq6CqK2qGOeeRCeq6fkv/w0wZv8G+zg08Z4/WQungkVlEi2xDi+ NIVGbZ7CKS4oo9LXRTLwqe6If9sH3hyGFP1ww7Ya8P5eqUI9mZEhTJBIp688/Z5XILvW /4EiIEYrTDjAA5r5mq10aD1iBsj9SgauBaxwO8/XtCcxtc/ozxcM2D4jtfhBg/OdLdUA SJBaOh6ikKlbFqrl42wcp1Vue7XmF/qsj4ixO0PZgn/85krlcJzRSewDNNjuwBq35D6Z VJMCmx84GzG+T16/fjb/5TEdSwBeS9Ji+EICqT0ysWHioRQNbuv3NlBPzBLFdaLXEUoF d0Ow== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence:ui-outboundreport :sensitivity:importance:date:subject:to:message-id:mime-version :dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=P0y+tRpL9I8XqSNxStn5jcYRhyVNV7kmBAdx/K//gSY=; b=hJi6mVzKxf+dSSP99felJd+xsxNeA2DALmWsrREh18AbY0p+P7SaPwZOq3IXSu6Lwd gWL4Ts13SL2UbwtBcuZK9fn6xdCJqTMHmMTZfKE/3lz/FR/1fzyqC5vbVIz/vmgcCB1Y gmQwOmcHt1MKMZ3F7Rj58fcNFYb3a1xEs+zRY0LoZDBsv91VwQLdbcmjAkBCpZTGd9yS Rk5xiV+KyucWVc++UMqs1B9vqYdyViRy/IIETPkn8INyyrnUlVBX9cBASFnVJkhKfPqI 1ZTPsh60JwrLKoSS/Bq1GRG+B4YO3oGJni6kT5VaR+F9WVVoV524natttxs5a8QeXhK9 JZgA== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=Zf2SlMKV; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id by15-20020a0564021b0f00b00514b26af7bdsi3659092edb.206.2023.06.22.13.24.11 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 22 Jun 2023 13:24:11 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=Zf2SlMKV; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 443453858C74 for ; Thu, 22 Jun 2023 20:24:10 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 443453858C74 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1687465450; bh=P0y+tRpL9I8XqSNxStn5jcYRhyVNV7kmBAdx/K//gSY=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=Zf2SlMKV1vnyUaFKKZAaP4pJAKG5qLnyZVxy2qbwHxqzfNIFpRG2xudnauId/nTiq zxCZ5oqNkP3DTU5g2P1DXzcFyQFYoAPRY7R36ZMJ0Cty6Tgsb+CgG2Y1sNNNkTwDO7 l/+AYGfO92du3vTt6lXClc8F0Ppn22ysAh7pe0FU= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.18]) by sourceware.org (Postfix) with ESMTPS id 97F9A3858D35; Thu, 22 Jun 2023 20:23:26 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 97F9A3858D35 X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.148.146] ([79.232.148.146]) by web-mail.gmx.net (3c-app-gmx-bs06.server.lan [172.19.170.55]) (via HTTP); Thu, 22 Jun 2023 22:23:24 +0200 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] Fortran: ABI for scalar CHARACTER(LEN=1),VALUE dummy argument [PR110360] Date: Thu, 22 Jun 2023 22:23:24 +0200 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:Ds06O3tt257Rw0TjF283so4FKYxpFJNUwi9Me1AgZaCU1amIcXJQMuLazHctn9+tf9poi wpvvhkMU8vMM1F22GHCWtvNJWsawUJHPJdPUwIMA4cIxGwthv5hrogP12jcVYhVy4iEuqUzWIChw FL5BOGXDrmO/m6FcCqowc2o1KO5KxV1Mq6sAOVaM+zp3iBTDaVKb9gbjsBZnPq6uETLNOGVe9gne G65xKHfHyR4NgHVC5BU1ZHZKC90FpTAZIMZxP4khmqKZdwXrcgX8zUoTUQTiUa1T4DSYEJ1DI6o/ YQ= UI-OutboundReport: notjunk:1;M01:P0:WLYlGYvzhVw=;aZ/E4pbDvp3X1DNfjPdHWsOSENF Ri554gfUeBNP1PuXoa3oEWJSD6pQPf1EB/3RIsOxA+NRa+sQNkBoolf6nqg/7jm3si6VvE931 6zlgmNOU8CtGcO5Z5D7KSSYLNn37CxknV7S8am2PWA/6XRhIQhxTrww/xQwVR2ctU9NOKnaIW 97Y8vmq0rpW3E8uza91tHE4Kfyxi9RG9WLXFwynCk+KXiyAuVauOwRVqM+XObfVZKPkjSANIS kmZV1R5+4uHcyQmAGFSA4XuHLujVB3zq9wmo5E0cl+IKbdXb27/TjIncRMQean+wmkOndctYH aJ38tGvrnXFMQVe/J/VgovziShDjWCH1nvGpx2e8rIyKeTJn8XFZzRMNEIVADOIsP6RGQKwFr vZaum02MME2bDGM3xrADrW6sWpGSnWEG3E8cXu55d4ezCwNGXuDTDXC9YF86azP+HPytEVJUp qLt5DLR2JSd3V+4o/IWqkJ/XQGySYw4N5igXwwgGgZCQ9AmZ6WSfRDLAFuq4YKwxOMRjaPqzI kCirLPtPTdgoDbEOUCOjFhVy8324rDW+dkAwfrThhO7Cd0MRmFNnQrmAL6lI3mbQqqyC/pKHB 9avHGMLj6Jeh1QUx8VhaNgqfKXlZ706MgQYIK6r0DuemGgCETi1dtbGXdaFzWToTO4MktxYrB 0OS4uXgXzhScv2sv9N6lJ5NzrCY7xdXjUyJ65lLt8DaB1IoOeFka54V4Nl+v9qDPZt3vRWWRS SYZ9Og8mvwa5GoOujSPqaXAU2igw5Qlx+udSPo7wP/LdBqwv12MjZwnUte+EtVLxVtKDXoD3b AbYfB3+MQuoH9dqlWtMbscqw== X-Spam-Status: No, score=-12.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1769435773416508347?= X-GMAIL-MSGID: =?utf-8?q?1769435773416508347?= Dear all, gfortran's ABI specifies that actual arguments to CHARACTER(LEN=1),VALUE dummy arguments are passed by value in the scalar case. That did work for constant strings being passed, but not in several other cases, where pointers were passed, resulting in subsequent random junk... The attached patch fixes this for the case of a non-constant string argument. It does not touch the character,value bind(c) case - this is a different thing and may need separate work, as Mikael pointed out - and there is a missed optimization for the case of actual constant string arguments of length larger than 1: it appears that the full string is pushed to the stack. I did not address that, as the primary aim here is to get correctly working code. (I added a TODO in a comment.) Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From bea1e14490e4abc4b67bae8fdca5196bb93acd2d Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Thu, 22 Jun 2023 22:07:41 +0200 Subject: [PATCH] Fortran: ABI for scalar CHARACTER(LEN=1),VALUE dummy argument [PR110360] gcc/fortran/ChangeLog: PR fortran/110360 * trans-expr.cc (gfc_conv_procedure_call): Pass actual argument to scalar CHARACTER(1),VALUE dummy argument by value. gcc/testsuite/ChangeLog: PR fortran/110360 * gfortran.dg/value_9.f90: New test. --- gcc/fortran/trans-expr.cc | 19 +++++++ gcc/testsuite/gfortran.dg/value_9.f90 | 78 +++++++++++++++++++++++++++ 2 files changed, 97 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/value_9.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3c209bcde97..c92fccd0be2 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6392,6 +6392,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { gfc_conv_expr (&parmse, e); + + /* ABI: actual arguments to CHARACTER(len=1),VALUE + dummy arguments are actually passed by value. + The BIND(C) case is handled elsewhere. + TODO: truncate constant strings to length 1. */ + if (fsym->ts.type == BT_CHARACTER + && !fsym->ts.is_c_interop + && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && fsym->ts.u.cl->length->ts.type == BT_INTEGER + && (mpz_cmp_ui + (fsym->ts.u.cl->length->value.integer, 1) == 0) + && e->expr_type != EXPR_CONSTANT) + { + parmse.expr = gfc_string_to_single_character + (build_int_cst (gfc_charlen_type_node, 1), + parmse.expr, + e->ts.kind); + } + if (fsym->attr.optional && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED) diff --git a/gcc/testsuite/gfortran.dg/value_9.f90 b/gcc/testsuite/gfortran.dg/value_9.f90 new file mode 100644 index 00000000000..f6490645e27 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/value_9.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! PR fortran/110360 - ABI for scalar character(len=1),value dummy argument + +program p + implicit none + character, allocatable :: ca + character, pointer :: cp + character(len=:), allocatable :: cd + character (kind=4), allocatable :: ca4 + character (kind=4), pointer :: cp4 + character(len=:,kind=4), allocatable :: cd4 + integer :: a = 65 + allocate (ca, cp, ca4, cp4) + + ! Check len=1 actual argument cases first + ca = "a"; cp = "b"; cd = "c" + ca4 = 4_"d"; cp4 = 4_"e"; cd4 = 4_"f" + call val ("B","B") + call val ("A",char(65)) + call val ("A",char(a)) + call val ("A",mychar(65)) + call val ("A",mychar(a)) + call val4 (4_"C",4_"C") + call val4 (4_"A",char(65,kind=4)) + call val4 (4_"A",char(a, kind=4)) + call val (ca,ca) + call val (cp,cp) + call val (cd,cd) + call val4 (ca4,ca4) + call val4 (cp4,cp4) + call val4 (cd4,cd4) + call sub ("S") + call sub4 (4_"T") + + ! Check that always the first character of the string is finally used + call val ( "U++", "U--") + call val4 (4_"V**",4_"V//") + call sub ( "WTY") + call sub4 (4_"ZXV") + cd = "gkl"; cd4 = 4_"hmn" + call val (cd,cd) + call val4 (cd4,cd4) + call sub (cd) + call sub4 (cd4) + deallocate (ca, cp, ca4, cp4, cd, cd4) +contains + subroutine val (x, c) + character(kind=1), intent(in) :: x ! control: pass by reference + character(kind=1), value :: c + print *, "by value(kind=1): ", c + if (c /= x) stop 1 + c = "*" + if (c /= "*") stop 2 + end + + subroutine val4 (x, c) + character(kind=4), intent(in) :: x ! control: pass by reference + character(kind=4), value :: c + print *, "by value(kind=4): ", c + if (c /= x) stop 3 + c = 4_"#" + if (c /= 4_"#") stop 4 + end + + subroutine sub (s) + character(*), intent(in) :: s + call val (s, s) + end + subroutine sub4 (s) + character(kind=4,len=*), intent(in) :: s + call val4 (s, s) + end + + character function mychar (i) + integer, intent(in) :: i + mychar = char (i) + end +end -- 2.35.3