From patchwork Wed Aug 9 20:21:20 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 133483 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:c44e:0:b0:3f2:4152:657d with SMTP id w14csp3053392vqr; Wed, 9 Aug 2023 13:23:56 -0700 (PDT) X-Google-Smtp-Source: AGHT+IHxLwYdmiaeBnjwp0IIoZiLXP0+n9KOvpxRffT4ry7QRaReidAUMHmzw1298FzHzmey6gDo X-Received: by 2002:a05:6512:3136:b0:4fb:7666:3bbf with SMTP id p22-20020a056512313600b004fb76663bbfmr135305lfd.26.1691612635989; Wed, 09 Aug 2023 13:23:55 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1691612635; cv=none; d=google.com; s=arc-20160816; b=nVNOPrKj3x+7oRbsn59c5tNcy+885gLrrKz6l7aNnH0vBjp/nQLHiyyqpnSi6vQ11R zvuxPLgeoglflkCb4e478DbmCjgY0kHzJPcfHgzbHN3LeGNhzXrHW0Rt8i70b1En7ABS YtvpvuSOysUdhqVzxW/lcPPC3s+6mUh+GYAj4CIke3nNTUVe6tx76BLMQSjwSVV2qU1O YZPCZfF+KAYKazSC1olgJg/SO06rpxm7rrjtEqQkWAAouumodn6vm2WlJjnhM5uV57kf FzphI+5jYPbCSr2dR4Kzs1evsIiNmN4gixx21WTjCsglhi/GCo5ORMB3MhhxH10BglIi k54Q== 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 :content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:to:dmarc-filter:delivered-to:dkim-signature :dkim-filter; bh=bEOGboPTZeLZPH3V3a3fo1Iu+qywHXPkfjc/aFsYHuc=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=ro5F+Mhd++GJplJk+5uKpaVvCqBuZkkWj7x2yvwXETE7WRy4KM7h8cKToaVyKh0xXh cqawqJOgKkGARShjdjMLt7liM1RTF3h9fnWXNwQCawiSRKCkGeMp44qpm8OorPmCqzsn /Bl7zxBKbDGZhJPFdkxzllNyM40TN0oMe12yHeWaAVkYvt0FWussksG/URhZU9l9CxAV sBGWVs0bk/3QSA0pQu8SgqX8iAn5GeokxdXA1NETgR3WIS1qEWcc3FGYWZyhcHbF8KJh vEyt+qdLWRNpKhqul1D0fwZZjGEI6Dbgw7lSthfPxq0k7sz6NCdkR1nVQFipwaQgpCTs j3nw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=f7Oq47OY; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c 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 (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id c26-20020a170906155a00b00997bd26a559si8611272ejd.881.2023.08.09.13.23.55 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 09 Aug 2023 13:23:55 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=f7Oq47OY; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c 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 903A438313AC for ; Wed, 9 Aug 2023 20:22:34 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 903A438313AC DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1691612554; bh=bEOGboPTZeLZPH3V3a3fo1Iu+qywHXPkfjc/aFsYHuc=; h=To:Subject:Date:In-Reply-To:References:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=f7Oq47OY7bq2I6kqdT8ttp2WRSoCwqx3p9y37bgtKQMOUKiT4guluoHupgFD8G5+s +I0hx5pb5mIppxGU4SufuRRFb3jh6txPxwOnPSsUphLdJoINPjQnhHo1lTeaGwwTFy BH5hOAOjOfcCfIaVTIlwm7MxfP+sOkuijbfPV1WY= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-20.smtpout.orange.fr [80.12.242.20]) by sourceware.org (Postfix) with ESMTPS id AF3DD385E00E for ; Wed, 9 Aug 2023 20:21:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org AF3DD385E00E Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id TpgJquxgNE5mdTpgQq56Yq; Wed, 09 Aug 2023 22:21:30 +0200 X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Wed, 09 Aug 2023 22:21:30 +0200 X-ME-IP: 86.215.161.51 To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 1/3] fortran: New predicate gfc_length_one_character_type_p Date: Wed, 9 Aug 2023 22:21:20 +0200 Message-Id: <20230809202122.695376-2-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230809202122.695376-1-mikael@gcc.gnu.org> References: <20230809202122.695376-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-11.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_NEUTRAL, TXREP 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: Mikael Morin via Gcc-patches From: Mikael Morin Reply-To: Mikael Morin Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1773784411519290879 X-GMAIL-MSGID: 1773784411519290879 Introduce a new predicate to simplify conditionals checking for a character type whose length is the constant one. gcc/fortran/ChangeLog: * gfortran.h (gfc_length_one_character_type_p): New inline function. * check.cc (is_c_interoperable): Use gfc_length_one_character_type_p. * decl.cc (verify_bind_c_sym): Same. * trans-expr.cc (gfc_conv_procedure_call): Same. --- gcc/fortran/check.cc | 7 +++---- gcc/fortran/decl.cc | 4 +--- gcc/fortran/gfortran.h | 15 +++++++++++++++ gcc/fortran/trans-expr.cc | 8 ++------ 4 files changed, 21 insertions(+), 13 deletions(-) diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 4086dc71d34..6c45e6542f0 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -5250,10 +5250,9 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) && !gfc_simplify_expr (expr->ts.u.cl->length, 0)) gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); - if (!c_loc && expr->ts.u.cl - && (!expr->ts.u.cl->length - || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) + if (!c_loc + && expr->ts.u.cl + && !gfc_length_one_character_type_p (&expr->ts)) { *msg = "Type shall have a character length of 1"; return false; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 844345df77e..8182ef29f43 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -6064,9 +6064,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, /* BIND(C) functions cannot return a character string. */ if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) - if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL - || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) + if (!gfc_length_one_character_type_p (&tmp_sym->ts)) gfc_error ("Return type of BIND(C) function %qs of character " "type at %L must have length 1", tmp_sym->name, &(tmp_sym->declared_at)); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6482a885211..d44e5286626 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3181,6 +3181,21 @@ gfc_finalizer; /************************ Function prototypes *************************/ + +/* Returns true if the type specified in TS is a character type whose length + is the constant one. Otherwise returns false. */ + +inline bool +gfc_length_one_character_type_p (gfc_typespec *ts) +{ + return ts->type == BT_CHARACTER + && ts->u.cl + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER + && mpz_cmp_ui (ts->u.cl->length->value.integer, 1) == 0; +} + /* decl.cc */ bool gfc_in_match_data (void); match gfc_match_char_spec (gfc_typespec *); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index ef3e6d08f78..6da3975f77c 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6453,12 +6453,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, dummy arguments are actually passed by value. Strings are truncated to length 1. The BIND(C) case is handled elsewhere. */ - 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)) + if (!fsym->ts.is_c_interop + && gfc_length_one_character_type_p (&fsym->ts)) { if (e->expr_type != EXPR_CONSTANT) { From patchwork Wed Aug 9 20:21:21 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 133482 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:c44e:0:b0:3f2:4152:657d with SMTP id w14csp3053231vqr; Wed, 9 Aug 2023 13:23:34 -0700 (PDT) X-Google-Smtp-Source: AGHT+IHTlFfsQ4JMddKJ7tRYpiHcIDJo8k7oHopgq8wtcm7q1fIsH+rkTmhhH6QrVxr7AoE1RGgf X-Received: by 2002:a17:906:7486:b0:993:a379:6158 with SMTP id e6-20020a170906748600b00993a3796158mr173504ejl.17.1691612614536; Wed, 09 Aug 2023 13:23:34 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1691612614; cv=none; d=google.com; s=arc-20160816; b=bZJB0IPkfXZ3ru5u8/LJ+CQz3ozyVRSQzUt534J1mjZ4vBfs1l+/NXX0JN6G/G04uW QP10WWk+57gRqFrGE1giKAvhtdKi6+vgF8kCmn1R/lNELr/eFaAYg/ANAzdBqenxtb7m tuqHOAWm9rKSphetW2IaeClX6FN5vxkwS5UHmCseGSADcNr5Wop1sSkQmwJnQz3zt6Ch 8e8l8Ub+z/ErbTkMsVE2UJU19TRWP7o0TZ4cO+fUKDHu8dB00YTpeocn/tTQ1V2KOWJS bwM9UcfDXpcSbz2A7x70kPLix1v0I/8Ev7GHulXY0fsMKif8uENZsQabQ2MAcDeHf4ES 2DpQ== 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 :content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:to:dmarc-filter:delivered-to:dkim-signature :dkim-filter; bh=roXJLX87D3PEziMM+T/4FjCL7spMw/L5ANJUPDiurWE=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=nJukJl+7itReDUAxWwrGSrdCxHyps1aC+GSOFVAfPdd3doh6Vt70oUuFtCkVr9jJ5p J1w5Eq7zV8wIrT4735uzaeZQlEfy7Z192rAR7gjK733r5y7+A84mI+4718HcldXjue52 UeMDFRCnP1a62Q0hKNiu7rHvwPr9dzfKJGdO3lMpbbg25pd7Tztjh5k2mTZ74PbSyvxv ffRHglLVMFsOy5R5rEDHp5RQbaDrNvQDCOYUqkzXxy2Xxd5aW0rk5Tzc6KMirJrjjBRL wiiynUYmZ8Ix8aotCxJSYjFEgMx6RheG7OtSTMjb69e+Cy36yqjcs1pISPoQDLzCNvtY OAig== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=IYBEp2I6; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c 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 (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id r13-20020a170906350d00b0098f99048058si9859218eja.1015.2023.08.09.13.23.34 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 09 Aug 2023 13:23:34 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=IYBEp2I6; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c 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 258F43882649 for ; Wed, 9 Aug 2023 20:22:25 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 258F43882649 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1691612545; bh=roXJLX87D3PEziMM+T/4FjCL7spMw/L5ANJUPDiurWE=; h=To:Subject:Date:In-Reply-To:References:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=IYBEp2I6JToLjq4MkI9FeTXysmcAXT2kMaIHFG1MfyMV8bcoyMWZGbUIUZHQt+WGI 6Sreoil4J7aecTzXyUoat2Mp4e/JuXSGiMs9LcChyvBRXtRpUaBkONQ0qa5ymqdVrA oO6MiHMoCaW/GSSQtJEfKyCji4xuobYgO7gSdpOU= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-20.smtpout.orange.fr [80.12.242.20]) by sourceware.org (Postfix) with ESMTPS id BAA30385E01F for ; Wed, 9 Aug 2023 20:21:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org BAA30385E01F Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id TpgJquxgNE5mdTpgQq56Ys; Wed, 09 Aug 2023 22:21:30 +0200 X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Wed, 09 Aug 2023 22:21:30 +0200 X-ME-IP: 86.215.161.51 To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 2/3] fortran: Fix length one character dummy arg type [PR110419] Date: Wed, 9 Aug 2023 22:21:21 +0200 Message-Id: <20230809202122.695376-3-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230809202122.695376-1-mikael@gcc.gnu.org> References: <20230809202122.695376-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H4, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_NEUTRAL, TXREP autolearn=unavailable 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: Mikael Morin via Gcc-patches From: Mikael Morin Reply-To: Mikael Morin Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1773784388861253099 X-GMAIL-MSGID: 1773784388861253099 Revision r14-2171-g8736d6b14a4dfdfb58c80ccd398981b0fb5d00aa changed the argument passing convention for length 1 value dummy arguments to pass just the single character by value. However, the procedure declarations weren't updated to reflect the change in the argument types. This change does the missing argument type update. The change of argument types generated an internal error in gfc_conv_string_parameter with value_9.f90. Indeed, that function is not prepared for bare character type, so it is updated as well. The condition guarding the single character argument passing code is loosened to not exclude non-interoperable kind (this fixes a regression with c_char_tests_2.f03). Finally, the constant string argument passing code is updated as well to extract the single char and pass it instead of passing it as a length one string. As the code taking care of non-constant arguments was already doing this, the condition guarding it is just removed. With these changes, value_9.f90 passes on 32 bits big-endian powerpc. PR fortran/110360 PR fortran/110419 gcc/fortran/ChangeLog: * trans-types.cc (gfc_sym_type): Use a bare character type for length one value character dummy arguments. * trans-expr.cc (gfc_conv_string_parameter): Handle single character case. (gfc_conv_procedure_call): Don't exclude interoperable kinds from single character handling. For single character dummy arguments, extend the existing handling of non-constant expressions to constant expressions. gcc/testsuite/ChangeLog: * gfortran.dg/bind_c_usage_13.f03: Update tree dump patterns. --- gcc/fortran/trans-expr.cc | 35 +++++++++++-------- gcc/fortran/trans-types.cc | 5 ++- gcc/testsuite/gfortran.dg/bind_c_usage_13.f03 | 8 ++--- 3 files changed, 28 insertions(+), 20 deletions(-) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 6da3975f77c..d91cc9da221 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6451,26 +6451,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* ABI: actual arguments to CHARACTER(len=1),VALUE dummy arguments are actually passed by value. - Strings are truncated to length 1. - The BIND(C) case is handled elsewhere. */ - if (!fsym->ts.is_c_interop - && gfc_length_one_character_type_p (&fsym->ts)) + Strings are truncated to length 1. */ + if (gfc_length_one_character_type_p (&fsym->ts)) { - if (e->expr_type != EXPR_CONSTANT) - { - tree slen1 = build_int_cst (gfc_charlen_type_node, 1); - gfc_conv_string_parameter (&parmse); - parmse.expr = gfc_string_to_single_character (slen1, - parmse.expr, - e->ts.kind); - /* Truncate resulting string to length 1. */ - parmse.string_length = slen1; - } - else if (e->value.character.length > 1) + if (e->expr_type == EXPR_CONSTANT + && e->value.character.length > 1) { e->value.character.length = 1; gfc_conv_expr (&parmse, e); } + + tree slen1 = build_int_cst (gfc_charlen_type_node, 1); + gfc_conv_string_parameter (&parmse); + parmse.expr + = gfc_string_to_single_character (slen1, + parmse.expr, + e->ts.kind); + /* Truncate resulting string to length 1. */ + parmse.string_length = slen1; } if (fsym->attr.optional @@ -10610,6 +10608,13 @@ gfc_conv_string_parameter (gfc_se * se) { tree type; + if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE + && integer_onep (se->string_length)) + { + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + return; + } + if (TREE_CODE (se->expr) == STRING_CST) { type = TREE_TYPE (TREE_TYPE (se->expr)); diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 987e3d26c46..084b8c3ae2c 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -2313,7 +2313,10 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c) && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) || (sym->ts.deferred && (!sym->ts.u.cl - || !sym->ts.u.cl->backend_decl)))) + || !sym->ts.u.cl->backend_decl)) + || (sym->attr.dummy + && sym->attr.value + && gfc_length_one_character_type_p (&sym->ts)))) type = gfc_get_char_type (sym->ts.kind); else type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_13.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_13.f03 index 470bd59ed38..3cc9f8e0fe9 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_usage_13.f03 +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_13.f03 @@ -130,9 +130,9 @@ end program test ! { dg-final { scan-tree-dump "multiso .&.v..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } ! { dg-final { scan-tree-dump "multiso2 .&.w..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } ! -! { dg-final { scan-tree-dump "mult_val ..x., .x., 1, 1.;" "original" } } +! { dg-final { scan-tree-dump "mult_val .120, 120, 1, 1.;" "original" } } ! { dg-final { scan-tree-dump "multiso_val .121, 120.;" "original" } } -! { dg-final { scan-tree-dump "multiso2_val ..z., .x..;" "original" } } +! { dg-final { scan-tree-dump "multiso2_val .122, 120.;" "original" } } ! ! Single argument dump: ! @@ -144,7 +144,7 @@ end program test ! { dg-final { scan-tree-dump "subiso .&.v..1..lb: 1 sz: 1..;" "original" } } ! { dg-final { scan-tree-dump "subiso2 .&.w..1..lb: 1 sz: 1..;" "original" } } ! -! { dg-final { scan-tree-dump "sub_val ..x., 1.;" "original" } } +! { dg-final { scan-tree-dump "sub_val .120, 1.;" "original" } } ! { dg-final { scan-tree-dump "subiso_val .121.;" "original" } } -! { dg-final { scan-tree-dump "subiso2_val ..z..;" "original" } } +! { dg-final { scan-tree-dump "subiso2_val .122.;" "original" } } ! From patchwork Wed Aug 9 20:21:22 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 133485 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:c44e:0:b0:3f2:4152:657d with SMTP id w14csp3053813vqr; Wed, 9 Aug 2023 13:24:45 -0700 (PDT) X-Google-Smtp-Source: AGHT+IHneUGCzplO9AxC5QLbSmrQcH/U2axv7On1xGVBv3bIFFyo6C06/2lJjNeLvTz0SMDck/9c X-Received: by 2002:a5d:444f:0:b0:317:5b3f:1998 with SMTP id x15-20020a5d444f000000b003175b3f1998mr285894wrr.58.1691612685101; Wed, 09 Aug 2023 13:24:45 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1691612685; cv=none; d=google.com; s=arc-20160816; b=DFl2Os0VHfyZQwdnIt7JEs39a+91ucrfTeIzUPat4AZWwkSAw8f788X6Rh8Fi10pml 0S99fq0m7OtQwC5OhKMOitmoMaMV0NPF1LGVmW55G6OnqFXVSQCj5KFN9lDS4iyyn32/ YO+J1Bj3HJIHxttUog14uR3Uv0KPEqML1F70GbMczYH5TRqaSZKpqQsyGMolxc7khciP kGmhVFydrZ/V3kk7CG6GXd4JTwWphRZVJJn2APHXbDajuXx5ET9vacNddefsduHal5In i4C+uCcJw8MMvHt3o8w+95PgbAqf2Yef77GA8tV3W5bJlE4Q12A1Pm5fyuXK/Sp8WAb7 BigQ== 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 :content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:to:dmarc-filter:delivered-to:dkim-signature :dkim-filter; bh=Ht2XS36QlC5nLHquJLiri2HV+ECZ94fmum87xx9W2SI=; fh=EAqAZnhg4AYtcBjfPm18lEF5V0R2rkI9MSWQf+svVaI=; b=C3Nb4xxL4baD+lBDmPt9FodTdE8gpZkl1d/2uXZBaRDDjzuMCuSUu20ih0ZjvByz1s Pu38JYOzU7Z1pwbnwBU2WLZ3hl2ihKq8/Fm5JzTA3PzGhJ+BR2f0+XEiGDYkZJ4MQWBN G5S8/8EfqMQBPMZ/ZGBnOFhA00cxWVix6TZfVS66pDtzkVLdhoqe9HqSXoJOs27tbrhZ WISR6fivtMepQS0+r1VUh5cFPjp7fQxv8nTDkqQco7/fUSTgelmPERr1AOEM7b47nShq Zz/y7RPW2QKLcPsNYJpCvo+TtrzNmkf2bxp/isJaWvAJzGHXuvzflNfkF9G5zEn1baFg ca2w== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=cB8F2vGz; 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 (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id z12-20020aa7d40c000000b005233567744fsi6072433edq.154.2023.08.09.13.24.44 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 09 Aug 2023 13:24:45 -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=cB8F2vGz; 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 5D863388200E for ; Wed, 9 Aug 2023 20:23:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 5D863388200E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1691612594; bh=Ht2XS36QlC5nLHquJLiri2HV+ECZ94fmum87xx9W2SI=; h=To:Subject:Date:In-Reply-To:References:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:List-Subscribe:From:Reply-To: From; b=cB8F2vGzGzITY5N+NCWLd4VNUJMoKwsknnd/su/00KKSiRM/mZQYwPWTE9HZLt6QG 9zBfw51osMapDmutpEybL7CAP+iQkY6LUBVYv4H04PDzsC8whZEa30aMaTpg/s3P8f XGliUfXrwY8gj64KfwpLPWCIrS+R0Fg41pNx07VU= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-19.smtpout.orange.fr [80.12.242.19]) by sourceware.org (Postfix) with ESMTPS id BB0E3385E021 for ; Wed, 9 Aug 2023 20:21:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org BB0E3385E021 Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id TpgJquxgNE5mdTpgQq56Yu; Wed, 09 Aug 2023 22:21:30 +0200 X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Wed, 09 Aug 2023 22:21:30 +0200 X-ME-IP: 86.215.161.51 To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 3/3] testsuite: Use distinct explicit error codes in value_9.f90 Date: Wed, 9 Aug 2023 22:21:22 +0200 Message-Id: <20230809202122.695376-4-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230809202122.695376-1-mikael@gcc.gnu.org> References: <20230809202122.695376-1-mikael@gcc.gnu.org> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FORGED_SPF_HELO, GIT_PATCH_0, JMQ_SPF_NEUTRAL, KAM_NUMSUBJECT, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H2, SPF_HELO_PASS, SPF_NEUTRAL, TXREP autolearn=unavailable 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: Mikael Morin via Gcc-patches From: Mikael Morin Reply-To: Mikael Morin Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1773784463020935184 X-GMAIL-MSGID: 1773784463020935184 Use distinct error codes, so that we can spot directly from the testsuite log which case is failing. gcc/testsuite/ChangeLog: * gfortran.dg/value_9.f90 (val, val4, sub, sub4): Take the error codes from the arguments. (p): Update calls: pass explicit distinct error codes. --- gcc/testsuite/gfortran.dg/value_9.f90 | 108 +++++++++++++------------- 1 file changed, 56 insertions(+), 52 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/value_9.f90 b/gcc/testsuite/gfortran.dg/value_9.f90 index 1a2fa80ed0d..4813250ebaa 100644 --- a/gcc/testsuite/gfortran.dg/value_9.f90 +++ b/gcc/testsuite/gfortran.dg/value_9.f90 @@ -20,78 +20,82 @@ program p ! 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 val ("1",c) - call val ("1",(c)) - call val4 (4_"C",4_"C") - call val4 (4_"A",char(65,kind=4)) - call val4 (4_"A",char(a, kind=4)) - call val4 (4_"4",c4) - call val4 (4_"4",(c4)) - call val (ca,ca) - call val (cp,cp) - call val (cd,cd) - call val (ca,(ca)) - call val4 (ca4,ca4) - call val4 (cp4,cp4) - call val4 (cd4,cd4) - call val4 (cd4,(cd4)) - call sub ("S") - call sub4 (4_"T") + call val ("B","B", 1, 2) + call val ("A",char(65), 3, 4) + call val ("A",char(a), 5, 6) + call val ("A",mychar(65), 7, 8) + call val ("A",mychar(a), 9, 10) + call val ("1",c, 11, 12) + call val ("1",(c), 13, 14) + call val4 (4_"C",4_"C", 15, 16) + call val4 (4_"A",char(65,kind=4), 17, 18) + call val4 (4_"A",char(a, kind=4), 19, 20) + call val4 (4_"4",c4, 21, 22) + call val4 (4_"4",(c4), 23, 24) + call val (ca,ca, 25, 26) + call val (cp,cp, 27, 28) + call val (cd,cd, 29, 30) + call val (ca,(ca), 31, 32) + call val4 (ca4,ca4, 33, 34) + call val4 (cp4,cp4, 35, 36) + call val4 (cd4,cd4, 37, 38) + call val4 (cd4,(cd4), 39, 40) + call sub ("S", 41, 42) + call sub4 (4_"T", 43, 44) ! 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") - call val ( "234", d ) - call val4 (4_"345", d4 ) - call val ( "234", (d) ) - call val4 (4_"345", (d4) ) - call val ( "234", d (1:2)) - call val4 (4_"345", d4(1:2)) - call val ( "234", d (1:l)) - call val4 (4_"345", d4(1:l)) - call val ("1",c // d) - call val ("1",trim (c // d)) - call val4 (4_"4",c4 // d4) - call val4 (4_"4",trim (c4 // d4)) + call val ( "U++", "U--", 45, 46) + call val4 (4_"V**",4_"V//", 47, 48) + call sub ( "WTY", 49, 50) + call sub4 (4_"ZXV", 51, 52) + call val ( "234", d , 53, 54) + call val4 (4_"345", d4 , 55, 56) + call val ( "234", (d) , 57, 58) + call val4 (4_"345", (d4) , 59, 60) + call val ( "234", d (1:2), 61, 62) + call val4 (4_"345", d4(1:2), 63, 64) + call val ( "234", d (1:l), 65, 66) + call val4 (4_"345", d4(1:l), 67, 68) + call val ("1",c // d, 69, 70) + call val ("1",trim (c // d), 71, 72) + call val4 (4_"4",c4 // d4, 73, 74) + call val4 (4_"4",trim (c4 // d4), 75, 76) cd = "gkl"; cd4 = 4_"hmn" - call val (cd,cd) - call val4 (cd4,cd4) - call sub (cd) - call sub4 (cd4) + call val (cd,cd, 77, 78) + call val4 (cd4,cd4, 79, 80) + call sub (cd, 81, 82) + call sub4 (cd4, 83, 84) deallocate (ca, cp, ca4, cp4, cd, cd4) contains - subroutine val (x, c) + subroutine val (x, c, err1, err2) character(kind=1), intent(in) :: x ! control: pass by reference character(kind=1), value :: c + integer, intent(in) :: err1, err2 print *, "by value(kind=1): ", c - if (c /= x) stop 1 + if (c /= x) stop err1 c = "*" - if (c /= "*") stop 2 + if (c /= "*") stop err2 end - subroutine val4 (x, c) + subroutine val4 (x, c, err1, err2) character(kind=4), intent(in) :: x ! control: pass by reference character(kind=4), value :: c + integer, intent(in) :: err1, err2 print *, "by value(kind=4): ", c - if (c /= x) stop 3 + if (c /= x) stop err1 c = 4_"#" - if (c /= 4_"#") stop 4 + if (c /= 4_"#") stop err2 end - subroutine sub (s) + subroutine sub (s, err1, err2) character(*), intent(in) :: s - call val (s, s) + integer, intent(in) :: err1, err2 + call val (s, s, err1, err2) end - subroutine sub4 (s) + subroutine sub4 (s, err1, err2) character(kind=4,len=*), intent(in) :: s - call val4 (s, s) + integer, intent(in) :: err1, err2 + call val4 (s, s, err1, err2) end character function mychar (i)