From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mout.gmx.net (mout.gmx.net [212.227.17.21]) by sourceware.org (Postfix) with ESMTPS id 1A2533858D3C; Tue, 12 Mar 2024 22:12:24 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1A2533858D3C Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 1A2533858D3C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.17.21 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710281546; cv=none; b=rnnpioGn2hXhUhWBKkIFNR2cf63Sx/ZFAe110Wg1rbNpraOtGLPKF9bo11gHNqVlJ7co0TrO6AXg3KHuXPxHcrE2wsyOiUmhHOa03w5ePAiOJTBqJ34vcjdctjyfsQniMY2GtVMxqSErTSxr6u9FgkhyJKshsV5N8/1XtqA3oJs= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1710281546; c=relaxed/simple; bh=KZansU7yhvY0s/iINvC4sDk+u9b+blM0xdeF+2BMuiE=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=UjsD0zSmfrO84q0HDn9nC/4GPH7JfTnd74v4DDzdncdyNtmxRwX1m063oEgJ1zeHAPYBIkJVIsJRqLqQ7/O41UAuBeMofHJUtaHOFeHgxy3MCMBbQq26XsPhxn5kMtutryLhP+36TaTagKTmbVeyqFgaVfTu2dO80I8GruWey7o= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1710281542; x=1710886342; i=anlauf@gmx.de; bh=KZansU7yhvY0s/iINvC4sDk+u9b+blM0xdeF+2BMuiE=; h=X-UI-Sender-Class:From:To:Subject:Date; b=nXy5PnbKRP4R6997n0fZ9GBfkNo8rDkHGQKWQ13131etDADmDX/Qd0URh9+/OWd+ j79tthfCQVN0Gp/P+V8MVnTKoh/b3vD4sUKYpmmp2cHrzMp8CV6mr1rz66Kw+EecI SkDf5v/okEGYptur3OrIMZds8omE+kk5MywZ+kzw0gFhX6CL7GGrhmIk2pFt9TWO9 Rme5bpGdwJh+Z0Km63UTojCdRXhDVkZjUBGUyu1Yq8vkLhv3DUQtDybA8dfe4mfk2 t5DZ3sNyn1VOZ2TEwv6zDqVGUYtSOXLluOonA6nplgZD5hYKL3v74N5VL7fRR6XI7 3EukvrWRyR1B37bJBQ== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.146.234] ([79.232.146.234]) by web-mail.gmx.net (3c-app-gmx-bap41.server.lan [172.19.172.111]) (via HTTP); Tue, 12 Mar 2024 23:12:22 +0100 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001] Content-Type: multipart/mixed; boundary=rekceb-76a6df1f-a377-4974-a201-96e66157b3ee Date: Tue, 12 Mar 2024 23:12:22 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:9zR0b8RYP9RW2UwfkrCM7u4zBp7bpGhz79BBV+8ncOM15LCwok7d9cNg3dip1qvQhScmB x78sAC2nptprU13Z/eWym6gZTR/2YFXFAUyoxgkR7KZ38eenoxCbGFlvxfluAwyEIgLjdChXm+Wg xA+Cuo1n8MRqEcmPwovieaVBPWncLK+/cxR2jcH0QprjC8rbAJ706rjyTPbnZ6N6Aw3BOXm9h3cN mbc7bjVQe1kOHPH+2fWaOM7xtDR3HkUXz7kqctflSIbe6QtZZ6gi4Z7KJ+4igZfithHERFArJImy Ro= UI-OutboundReport: notjunk:1;M01:P0:YG/j84+La3k=;KQE97KmFtx8PsvmCJTIFnNFKHDn I+zRUR/z3ThQo77XGA7qVvZYkY8Mof3BUKojAIbrixqZVSa//nXGyy5LkcgdqqfFh29RL9jR6 qI+zDnyvy0zWW7kLkCsx/8MdY8BRw9jfV6PKa/cVieKptOLN29RAWGcKmyGuuV2Ib5e0PbInI QNTcJu298+BiyUrRTZvAmW1yymuHraufXoJ9QRCop3+4EqesW0ZGHAZPDjrB1l91PPFoVJwb1 mB7edS2yFC4WGxBdrDuddlI2NPCsh0xACCb+Oa2Vr/wgGahcQkg8tSrZEua4S0N3puoAa4Rbo okiu9ZwlDW2pnqwVVR9406O485otQxdmtR2in/wxljGfkY6ZqsB7mN1yO2tH3UXiLtUuebMfa NNTCMNGesNQIkuXkmoT/ez2AQgfZTTotG3N5GsyU4qZ+kWBfQJftnXU7xMUUj0u4GWF+iYbUU zMmZDVSqblhQgD/Dq2FHtUE57Ib9c2Nwc6UDYx3PoMg0nXdEg8ydCUi7pwNQEtthzyAiTqz3Y bQiRjPKdw/D585uFHg4CbvBP34hsk7Q7rGLCcPaerBfMm3j1mM8t7rBAQf/bptQWAifxKUp19 eXFb9qASxPvn1SnOKxAiXYnLODzVNHyB1juwXtqnbv7TeWVcsFunxfsmgzIvQzbNLmNpt0BYj uXkHKDIfDhxiCGQOTB4qVxO2TyFzXSMPUwCEGe9Qc5Iw4QGNruvcosuwc1RYJ2I= X-Spam-Status: No, score=-9.6 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,DKIM_VALID_AU,DKIM_VALID_EF,FREEMAIL_FROM,GIT_PATCH_0,RCVD_IN_BARRACUDACENTRAL,RCVD_IN_DNSWL_LOW,RCVD_IN_MSPIKE_H3,RCVD_IN_MSPIKE_WL,RCVD_IN_SORBS_WEB,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 List-Id: --rekceb-76a6df1f-a377-4974-a201-96e66157b3ee Content-Type: text/plain; charset=UTF-8 Dear all, here's another small fix: IS_CONTIGUOUS did erroneously always return .true. for CLASS dummy arguments. The solution was to adjust the logic in gfc_is_simply_contiguous to also handle CLASS symbols. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald --rekceb-76a6df1f-a377-4974-a201-96e66157b3ee Content-Type: text/x-patch Content-Disposition: attachment; filename=pr114001.diff Content-Transfer-Encoding: quoted-printable =46rom 8f535b19bd0cb6a7c99ac9ba4c07778f86698a1c Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 12 Mar 2024 22:58:39 +0100 Subject: [PATCH] Fortran: fix IS_CONTIGUOUS for polymorphic dummy argument= s [PR114001] gcc/fortran/ChangeLog: PR fortran/114001 * expr.cc (gfc_is_simply_contiguous): Adjust logic so that CLASS symbols are also handled. gcc/testsuite/ChangeLog: PR fortran/114001 * gfortran.dg/is_contiguous_4.f90: New test. =2D-- gcc/fortran/expr.cc | 19 ++--- gcc/testsuite/gfortran.dg/is_contiguous_4.f90 | 81 +++++++++++++++++++ 2 files changed, 91 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/is_contiguous_4.f90 diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 37ea95d0185..82a642b01f7 100644 =2D-- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -6025,15 +6025,16 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool str= ict, bool permit_element) } sym =3D expr->symtree->n.sym; - if (expr->ts.type !=3D BT_CLASS - && ((part_ref - && !part_ref->u.c.component->attr.contiguous - && part_ref->u.c.component->attr.pointer) - || (!part_ref - && !sym->attr.contiguous - && (sym->attr.pointer - || (sym->as && sym->as->type =3D=3D AS_ASSUMED_RANK) - || (sym->as && sym->as->type =3D=3D AS_ASSUMED_SHAPE))))) + if ((part_ref + && part_ref->u.c.component + && !part_ref->u.c.component->attr.contiguous + && IS_POINTER (part_ref->u.c.component)) + || (!part_ref + && expr->ts.type !=3D BT_CLASS + && !sym->attr.contiguous + && (sym->attr.pointer + || (sym->as && sym->as->type =3D=3D AS_ASSUMED_RANK) + || (sym->as && sym->as->type =3D=3D AS_ASSUMED_SHAPE)))) return false; if (!ar || ar->type =3D=3D AR_FULL) diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_4.f90 b/gcc/testsuite= /gfortran.dg/is_contiguous_4.f90 new file mode 100644 index 00000000000..cb066f8836b =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! PR fortran/114001 - IS_CONTIGUOUS and polymorphic dummy + +program main + implicit none + integer :: i, cnt =3D 0 + logical :: expect + integer, target :: m(10) =3D [(i,i=3D1,size(m))] + integer, pointer :: p(:) + type t + integer :: j + end type t + type(t), pointer :: tt(:), tp(:) ! Type pointer + class(t), pointer :: ct(:), cp(:) ! Class pointer + + p =3D> m(1:3) + expect =3D is_contiguous (p) + print *, "is_contiguous (p)=3D", expect + if (.not. expect) stop 91 + call sub_star (p, expect) + p =3D> m(1::3) + expect =3D is_contiguous (p) + print *, "is_contiguous (p)=3D", expect + if (expect) stop 92 + call sub_star (p, expect) + + allocate (tt(10)) + tt(:)% j =3D m + tp =3D> tt(4:6) + expect =3D is_contiguous (tp) + if (.not. expect) stop 96 + print *, "is_contiguous (tp)=3D", expect + call sub_t (tp, expect) + tp =3D> tt(4::3) + expect =3D is_contiguous (tp) + if (expect) stop 97 + print *, "is_contiguous (tp)=3D", expect + call sub_t (tp, expect) + + allocate (ct(10)) + ct(:)% j =3D m + cp =3D> ct(7:9) + expect =3D is_contiguous (cp) + print *, "is_contiguous (cp)=3D", expect + if (.not. expect) stop 98 + call sub_t (cp, expect) + cp =3D> ct(4::3) + expect =3D is_contiguous (cp) + print *, "is_contiguous (cp)=3D", expect + if (expect) stop 99 + call sub_t (cp, expect) + +contains + + subroutine sub_star (x, expect) + class(*), intent(in) :: x(:) + logical, intent(in) :: expect + cnt =3D cnt + 10 + if (is_contiguous (x) .neqv. expect) then + print *, "sub_star(1): is_contiguous (x)=3D", is_contiguous (x), e= xpect + stop (cnt + 1) + end if + select type (x) + type is (integer) + if (is_contiguous (x) .neqv. expect) then + print *, "sub_star(2): is_contiguous (x)=3D", is_contiguous (x)= , expect + stop (cnt + 2) + end if + end select + end + + subroutine sub_t (x, expect) + class(t), intent(in) :: x(:) + logical, intent(in) :: expect + cnt =3D cnt + 10 + if (is_contiguous (x) .neqv. expect) then + print *, "sub_t: is_contiguous (x)=3D", is_contiguous (x), expect + stop (cnt + 3) + end if + end +end =2D- 2.35.3 --rekceb-76a6df1f-a377-4974-a201-96e66157b3ee--