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: 1808499 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: legolas.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=TxL6lVsX; dkim-atps=neutral Received: from server2.sourceware.org (ip-8-43-85-97.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (P-384) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4R3xh11XSYz20CW for ; Mon, 17 Jul 2023 06:31:26 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E097A38582A3 for ; Sun, 16 Jul 2023 20:31:22 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E097A38582A3 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1689539482; 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=TxL6lVsX61u9VvW+m3byHnJOr5yT1jfZHnYdHs7wesGO95ludHPQRisapIgBlx/lh bGHt8ZTdH3HkfcPCVpmzLm/ua36wNu0Fjn39OB726EZgU7XQs5+iZLbuDyIaOTHIUC yiPq4h5hVPW84lAACjeUGhowWCraFo5Uldr9AtA0= 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+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" 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