From patchwork Sun Jul 16 20:30:59 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 120927 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:c923:0:b0:3e4:2afc:c1 with SMTP id j3csp765785vqt; Sun, 16 Jul 2023 13:31:53 -0700 (PDT) X-Google-Smtp-Source: APBJJlFoLQnIP+dQ35+JA4YDY4iPWJ1kjKx/iRAdUMhQJVnmk1wLVuB6zj05WGQfvya6vWCecLY0 X-Received: by 2002:a17:906:715:b0:992:a618:c3c2 with SMTP id y21-20020a170906071500b00992a618c3c2mr9640372ejb.76.1689539513337; Sun, 16 Jul 2023 13:31:53 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1689539513; cv=none; d=google.com; s=arc-20160816; b=KtZmaQ5Bf8nCz7YU9R8t7JOUbldpX0GaPhlhs6alkswQhO7wssra+RVwUe+0ztcK/2 kjPj0KyhD+g2xwXrXST1bFd69t0wNZR7Pi5WLusLnzAgBRwseLk3CR1QAx+7q4F+LZGT yB1tPMKMABA3ZBsoPmI/x9EutlGTIyvz39JxDLHwV07zKx5E6pkbe1Zg2nrZMEtfmHlD h69u0x8qdGDMZDyPoNxVJetOkqyNQYjKiefQVxuHVMWyD+0GMSV4rmcn5UDKN3iMCmE0 Sk29+pb7Q2At7SG11/ZmCqewoihknlK2qi6jGKHMGPG2J4HX5WwiKpS2WNxDIxBLdNQU 7Ybg== 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=i/AzWhjHmAGmvi3np+Mdcj8ujZAZ9nGqdaJPeqX2fkQ=; fh=QK0YdXSiSCa48e9o4Ff7k6xpBN/ax2bSUZqWzYlsl7Q=; b=D/zjMGYiuedreFn6ffYF1pQIE/T3/YMhPXUEMN/Vp+U78d3ZQrplOd3nhYlmx+LHPN RoJ6fEZNwFJkj2fXykCH0JRps2kwB4Ws3lCEeKs4goPQYxSxORs67l/y6OeC6pZQvY8w fLojbW2fHRHxZLQSwTSZ/X4t9FkQvpHZ1ABKVKejS9Ul9b5C4o6PgLloUQVOyZw7zf8x XYw6RyCmBoS6OcQvdXBQjiRSMo2k1/jPzq0+Pngj872Go0bg04KD4tPAfaZbOZtycqFl AeYpwk/XTcQGYPUWo3wDmw0a2izOpOgXqQ2G7l3RDEwj83CPiP+N//cKYmZYTkqKmJWX FlBw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=iTYI77NP; 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 r23-20020a170906c29700b00992c30f5887si13931064ejz.474.2023.07.16.13.31.52 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 16 Jul 2023 13:31:53 -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=iTYI77NP; 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 270AC385802F for ; Sun, 16 Jul 2023 20:31:46 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 270AC385802F DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1689539506; bh=i/AzWhjHmAGmvi3np+Mdcj8ujZAZ9nGqdaJPeqX2fkQ=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=iTYI77NPRR4QS9UiZgtROdErwFplJHhgWisgHkALkklBwZHnCng7MYvHbx5zazYnF A54IbUYzWwSNOfH5jitiPciVlteNj2l1htEeQrY2qcnKnZjAjxC3lK7+U4n6nVj6M6 6SarrA/rZhhyv/JJnD0CmYrwzTfsT+rli3hPkEGo= 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.17.20]) by sourceware.org (Postfix) with ESMTPS id 722DB3858D28; Sun, 16 Jul 2023 20:31:01 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 722DB3858D28 X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.155.216] ([79.232.155.216]) by web-mail.gmx.net (3c-app-gmx-bap40.server.lan [172.19.172.110]) (via HTTP); Sun, 16 Jul 2023 22:30:59 +0200 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] Fortran: intrinsics and deferred-length character arguments [PR95947,PR110658] Date: Sun, 16 Jul 2023 22:30:59 +0200 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:yak58LZjax3zE2Ol/vjYmTfeRxQWWkLY9vSAic9c736Mrq8lDRTQQHTfsHG5pt9V+/7Lm 3qSVCI7epgZKdq9BYXDNCJcB4dgPricdRz54SI52IwqRh1BrG+L60FP728eOorC1qp7XkSNjOVdo +nW/L0PXvTO/BzzbhH3m8o+F2vIHdyb2Sr4+jNysW8TsHCGFCMVpzoSM7SwGMDIew3lrde/6ThVG 02NvwzXKbN5+CZoMTP/51dVQRff3/guA1m0TiSlbkz2pzKl5NJqO27zkHKnrsgIpxsCQ/gVMmhvc ME= UI-OutboundReport: notjunk:1;M01:P0:iCBDY/h1QM0=;gYZ2eXK3hGyxpokURVcLbHbuG35 YIB+CkIrwk+5qXydyD7IjEoHiHPEfaa1rpkxRYKLOGqaetNwxVWgDOXXj/BNptb60ivlJVfD9 1lm5CbMiZIL5EeFdi1sy0CXbqUqvj6Uc0T7hFGENi5cXeMtfI1acwhttf9xm337E6SpoXKP+P qtyEGGdj2/yIiwI4FaAmduOiHSsbJOpCvothu7bz7Y9Bca5FJe6t1sJ5wmXqmLdfgN7ZwxFXz 4MpcDsuLMf/eCZYmX2nXTSjZMw/iWaH2q8k0Cr7OZRIE2z61QDlWpMp+N/3YrhJxRQi2F6L+K mJgxlPKP3KrQhpGfp2K4nbL128pAz5XFB6KOu8yakpfIDjSBTOUJ7QgR8pibXVkNZA1VyeEic 4bqPuR2e2t/p2p1LmjiRuHYCJGcy2M3NS1rM5dT9p/twD7jalDR0wOTQZJcKOiBAi9raDcMnl /DNlSCrg7Mz+EJgIeX07CZy324jrGs6mvAyXkguOkJJnnPBmr4WojAX1dAZCou2UoaqWWTNJi LI69bhe0uWNk3Pok0wHoVyFGFikxu8LIIxui+zPxJKccPqMclUWd4C3jZTPJ5cqvqnXY89gpO 0VNutdhmVP5GS7YDQrP4mR1ZtODyCIqUvTnnBeEZBvB9l5wSLTCut+AtXu38rYcmu9pV2NUwg 5fH/pOeJDjzT9vuOFiH822fWYAKvXpJKQfPirhiVAG8MBmrrZBityUqmLye/QyjTmThpSD2OZ we1QFhpm/mwJnMtf1cQrJkyCQXGxZ9mjGPal1P3VHlM1uEB6lHZ0QY1JFAdPtjV9qyWmjLz1a Lqwt1FgZwOGw/n136bI67Z64kWCu83j0OGjJKhUHuSh5E= 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_H2, 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: INBOX X-GMAIL-THRID: 1771610584309031549 X-GMAIL-MSGID: 1771610584309031549 Dear all, some intrinsics may return character results with the same characteristics as their first argument (e.g. PACK, MINVAL, ...). If the first argument is of deferred-length, we need to derive the character length of the result from the first argument, like in the assumed-length case, but we must not handle it as deferred-length, as that has a different argument passing convention. The attached - almost trivial and obvious - patch fixes that. Regtested on x86_64-pc-linux-gnu. OK for mainline? As this is a rather simple fix for a wrong-code bug, I would like to backport this at least to 13-branch, unless there are major concerns. Thanks, Harald From 88d2694eb1278b0ad0d542565e0542c39fe6b466 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sun, 16 Jul 2023 22:17:27 +0200 Subject: [PATCH] Fortran: intrinsics and deferred-length character arguments [PR95947,PR110658] gcc/fortran/ChangeLog: PR fortran/95947 PR fortran/110658 * trans-expr.cc (gfc_conv_procedure_call): For intrinsic procedures whose result characteristics depends on the first argument and which can be of type character, the character length will not be deferred. gcc/testsuite/ChangeLog: PR fortran/95947 PR fortran/110658 * gfortran.dg/deferred_character_37.f90: New test. --- gcc/fortran/trans-expr.cc | 7 +- .../gfortran.dg/deferred_character_37.f90 | 88 +++++++++++++++++++ 2 files changed, 94 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_37.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index dbb04f8c434..d1570b31a82 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7654,7 +7654,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, (and other intrinsics?) and dummy functions. In the case of SPREAD, we take the character length of the first argument for the result. For dummies, we have to look through the formal argument list for - this function and use the character length found there.*/ + this function and use the character length found there. + Likewise, we handle the case of deferred-length character dummy + arguments to intrinsics that determine the characteristics of + the result, which cannot be deferred-length. */ + if (expr->value.function.isym) + ts.deferred = false; if (ts.deferred) cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen"); else if (!sym->attr.dummy) diff --git a/gcc/testsuite/gfortran.dg/deferred_character_37.f90 b/gcc/testsuite/gfortran.dg/deferred_character_37.f90 new file mode 100644 index 00000000000..8a5a8c5daf8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deferred_character_37.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! PR fortran/95947 +! PR fortran/110658 +! +! Test deferred-length character arguments to selected intrinsics +! that may return a character result of same length as first argument: +! CSHIFT, EOSHIFT, MAXVAL, MERGE, MINVAL, PACK, SPREAD, TRANSPOSE, UNPACK + +program p + implicit none + call pr95947 () + call pr110658 () + call s () + +contains + + subroutine pr95947 + character(len=:), allocatable :: m(:) + + m = [ character(len=10) :: 'ape','bat','cat','dog','eel','fly','gnu'] + m = pack (m, mask=(m(:)(2:2) == 'a')) + +! print *, "m = '", m,"' ", "; expected is ['bat','cat']" + if (.not. all (m == ['bat','cat'])) stop 1 + +! print *, "size(m) = ", size(m), "; expected is 2" + if (size (m) /= 2) stop 2 + +! print *, "len(m) = ", len(m), "; expected is 10" + if (len (m) /= 10) stop 3 + +! print *, "len_trim(m) = ", len_trim(m), "; expected is 3 3" + if (.not. all (len_trim(m) == [3,3])) stop 4 + end + + subroutine pr110658 + character(len=:), allocatable :: array(:), array2(:,:) + character(len=:), allocatable :: res, res1(:), res2(:) + + array = ["bb", "aa", "cc"] + + res = minval (array) + if (res /= "aa") stop 11 + + res = maxval (array, mask=[.true.,.true.,.false.]) + if (res /= "bb") stop 12 + + res1 = cshift (array, 1) + if (any (res1 /= ["aa","cc","bb"])) stop 13 + + res2 = eoshift (res1, -1) + if (any (res2 /= [" ", "aa", "cc"])) stop 14 + + res2 = pack (array, mask=[.true.,.false.,.true.]) + if (any (res2 /= ["bb","cc"])) stop 15 + + res2 = unpack (res2, mask=[.true.,.false.,.true.], field="aa") + if (any (res2 /= array)) stop 16 + + res2 = merge (res2, array, [.true.,.false.,.true.]) + if (any (res2 /= array)) stop 17 + + array2 = spread (array, dim=2, ncopies=2) + array2 = transpose (array2) + if (any (shape (array2) /= [2,3])) stop 18 + if (any (array2(2,:) /= array)) stop 19 + end + + subroutine s + character(:), allocatable :: array1(:), array2(:) + array1 = ["aa","cc","bb"] + array2 = copy (array1) + if (any (array1 /= array2)) stop 20 + end + + function copy (arg) result (res) + character(:), allocatable :: res(:) + character(*), intent(in) :: arg(:) + integer :: i, k, n + k = len (arg) + n = size (arg) + allocate (character(k) :: res(n)) + do i = 1, n + res(i) = arg(i) + end do + end + +end -- 2.35.3