From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mout.gmx.net (mout.gmx.net [212.227.15.15]) by sourceware.org (Postfix) with ESMTPS id F04983858D20; Mon, 12 Jun 2023 21:12:46 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org F04983858D20 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=gmx.de; s=s31663417; t=1686604365; x=1687209165; i=anlauf@gmx.de; bh=GfNNIw237n8EUsyO6qcyZ4h8pKpp5/mtxH9i0YOgO8g=; h=X-UI-Sender-Class:From:To:Subject:Date; b=LDJVUdiM2wQJDVEnAykRkg2avDgMPLC6YjJXNGachNuoypA7HjNI59h8nydI21i1hmnB6OX uNQm6EnnKYJRIbuDJPc52j+EJmJZsICFLzgl2YZk5KerzkfkbHma873doCp7Ht1M3vpCOcpvu IgkAiOMTp01BSlIZ8aBJzinllIjwiEeYeYz+M7M9Ni5eJICw2zZ84HnwHgGEh/Ez/L6J/VeVd gS1SCnWPG2KBE5onRa8qWxXSGCiHrEiFpM1LahdpSwd3Lx3YGyOPVloXGIOxynuM0LLma9F5x d5vUJzwfceSGBTTea7fH0IsTbb/TqpuRbJbou2APMa/u5EU7tQyQ== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [93.207.84.180] ([93.207.84.180]) by web-mail.gmx.net (3c-app-gmx-bs01.server.lan [172.19.170.50]) (via HTTP); Mon, 12 Jun 2023 23:12:45 +0200 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: fix passing of zero-sized array arguments to procedures [PR86277] Content-Type: multipart/mixed; boundary=rekceb-52f1e595-8664-425d-85b4-8b559772601f Date: Mon, 12 Jun 2023 23:12:45 +0200 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:3Yu7R8DsAV4dnzIY39361kXOITYg5EKHntIp5vC6R4ReJbVSCHhjWlxLJ+udS6aO5qoyH EdoiImEviUaDQ9lVza3+KrgVUsGXby7Zf8YkqA39yGjJH03zA0/QE1cBdf3hs/AADG7+0YwL4Dab ICoBtTKbTZxmFnmSyB6jzSSnMTtjVtqwHY+dDVFyww6/P8Ic7UACU0ODDWJ0GRvD6tj/8RpWQOoR ZDvCA8O9FCyUXN8HUa3tJehEZXvbBVmd1SEJhFGqW2dpS4PSJM/c1hRaAZZ3V81FZp5kKz+XEqtv t0= UI-OutboundReport: notjunk:1;M01:P0:B9dRbqUJmWI=;s3wCu166hZbQhy7QupgCc9FLquk ZdigwHIhhHuJkEE8M0kYJfqc+WmbrEphLp8iw4rxSZo+Ip9BH7wlwS82/sG23qguFPA5RpkIg GxGEGxRBZqUQRNpKth1K0VDUIRcKS/N43ZrQIvjkdr/6mOz4wTZTC63gJX0Tw/0vE/qAebswu d+OIV3CugXhwQ6aNeYRkS7t4ZO73e7/zx3WQOVaby36gWY0h411v57+GMNAcer6ugIhwzAe18 ERDYn1Fs8KfdZCHs73M2nZo87qQQUO0fEWxwp3XD3h0VMih8TAJg3JlKlDl5LVluP6bRAA+r0 vJGB8nUSEn6yCGLsKnDK9a0RClpBoJz4sndZ1p807c8K6/PXGq5/ldpvCxt+zDI9Gi98k/hjZ QJg2XdyxKuol5aIJOsLTc38NnHGB340dYK29YY9R6u9YnC3ksaZ3619ag+kqDKZp4E7LvCNkp GlXK/QjO4VpRydExL6KPuCaKW6W3YCGTX+X4RngsjoqU3bEy6ym8LMM/p19TDDcGea6E5YI8/ fQZmcfWOmucqlmjbqZK55lVVmhAHXtxdTz12o/5Uhr0yKzgIx0jpVMUaIYo3lcvCDiDZpDwWz aIg1P17IeTQxEDkQg8QakC/ShorMNCYRwx2oMVop5wNfLa29Fr/6OBQsjfUPEfkqvJhmDSYT9 5wIknJAyqiza7Z2jwrRaneHhSoC22a1ODZrqUhuTEms4rdIZ9E1iniULYCMdS+FjLbg25NfhX 5DjYN7BXfKHUdQn8QNUmbfM4z0rRts8HHknvNjiGlT0auD1uz40cHaJ5c1nUyKPlcZ/rnokm7 S8a+IKWVtQU2BVmKJdDmzzk4ctfA6m9d4Yr4BJoMXBbTI= X-Spam-Status: No, score=-12.0 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_H5,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 List-Id: --rekceb-52f1e595-8664-425d-85b4-8b559772601f Content-Type: text/plain; charset=UTF-8 Dear all, the attached - actually rather small - patch is the result of a rather intensive session with Mikael in an attempt to fix the situation that we did not create proper temporaries when passing zero-sized array arguments to procedures. When the dummy argument was declared as OPTIONAL, in many cases it was mis-detected as non-present. This also depended on the type of argument, and was different for different intrinsic types, notably character, and derived types, and should explain the rather large ratio of the size of the provided testcases to the actual fix... (What the patch does not address: we still generate too much code for unneeded temporaries, often two temporaries instead of just one. I'll open a separate PR to track this.) Regtested on x86_64-pc-linux-gnu. OK for mainline? If this survives long enough on 14-trunk, would this be eligible for a backport to 13-branch in time for 13.2? Thanks, Harald --rekceb-52f1e595-8664-425d-85b4-8b559772601f Content-Type: text/x-patch Content-Disposition: attachment; filename=pr86277.diff Content-Transfer-Encoding: quoted-printable =46rom 773b2aae412145d61638a0423c5891c4dfd0f945 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Mon, 12 Jun 2023 23:08:48 +0200 Subject: [PATCH] Fortran: fix passing of zero-sized array arguments to procedures [PR86277] gcc/fortran/ChangeLog: PR fortran/86277 * trans-array.cc (gfc_trans_allocate_array_storage): When passing a zero-sized array with fixed (=3D non-dynamic) size, allocate temporary by the caller, not by the callee. gcc/testsuite/ChangeLog: PR fortran/86277 * gfortran.dg/zero_sized_14.f90: New test. * gfortran.dg/zero_sized_15.f90: New test. Co-authored-by: Mikael Morin =2D-- gcc/fortran/trans-array.cc | 2 +- gcc/testsuite/gfortran.dg/zero_sized_14.f90 | 181 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/zero_sized_15.f90 | 114 ++++++++++++ 3 files changed, 296 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/zero_sized_14.f90 create mode 100644 gcc/testsuite/gfortran.dg/zero_sized_15.f90 diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e1c75e9fe02..e7c51bae052 100644 =2D-- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1117,7 +1117,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,= stmtblock_t * post, desc =3D info->descriptor; info->offset =3D gfc_index_zero_node; - if (size =3D=3D NULL_TREE || integer_zerop (size)) + if (size =3D=3D NULL_TREE || (dynamic && integer_zerop (size))) { /* A callee allocated array. */ gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); diff --git a/gcc/testsuite/gfortran.dg/zero_sized_14.f90 b/gcc/testsuite/g= fortran.dg/zero_sized_14.f90 new file mode 100644 index 00000000000..32c7ae28e3a =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/zero_sized_14.f90 @@ -0,0 +1,181 @@ +! { dg-do run } +! PR fortran/86277 +! +! Check proper detection of presence of optional array dummy arguments +! for zero-sized actual array arguments or array constructors: +! tests for REAL (as non-character intrinsic type) and empty derived type + +program test + implicit none + real, parameter :: m(0) =3D 42. + real, parameter :: n(1) =3D 23. + real :: x(0) =3D 1. + real :: z(1) =3D 2. + real :: w(0) + real, pointer :: p(:) + real, allocatable :: y(:) + integer :: k =3D 0, l =3D 0 ! Test/failure counter + type dt + ! Empty type + end type dt + type(dt), parameter :: t0(0) =3D dt() + type(dt), parameter :: t1(1) =3D dt() + type(dt) :: t2(0) =3D dt() + type(dt) :: t3(1) =3D dt() + type(dt) :: t4(0) + type(dt), allocatable :: tt(:) + ! + allocate (p(0)) + allocate (y(0)) + allocate (tt(0)) + call a0 () + call a1 () + call a2 () + call a3 () + call all_missing () + print *, "Total tests:", k, " failed:", l +contains + subroutine a0 () + print *, "Variables as actual argument" + call i (m) + call i (n) + call i (x) + call i (w) + call i (y) + call i (p) + call j (t0) + call j (t1) + call j (t2) + call j (t3) + call j (t4) + call j (tt) + print *, "Array section as actual argument" + call i (m(1:0)) + call i (n(1:0)) + call i (x(1:0)) + call i (w(1:0)) + call i (z(1:0)) + call i (p(1:0)) + call j (t0(1:0)) + call j (t1(1:0)) + call j (t2(1:0)) + call j (t3(1:0)) + call j (t4(1:0)) + call j (tt(1:0)) + end subroutine a0 + ! + subroutine a1 () + print *, "Explicit temporary as actual argument" + call i ((m)) + call i ((n)) + call i ((n(1:0))) + call i ((x)) + call i ((w)) + call i ((z(1:0))) + call i ((y)) + call i ((p)) + call i ((p(1:0))) + call j ((t0)) + call j ((t1)) + call j ((tt)) + call j ((t1(1:0))) + call j ((tt(1:0))) + end subroutine a1 + ! + subroutine a2 () + print *, "Array constructor as actual argument" + call i ([m]) + call i ([n]) + call i ([x]) + call i ([w]) + call i ([z]) + call i ([m(1:0)]) + call i ([n(1:0)]) + call i ([m,n(1:0)]) + call i ([x(1:0)]) + call i ([w(1:0)]) + call i ([z(1:0)]) + call i ([y]) + call i ([p]) + call i ([y,y]) + call i ([p,p]) + call i ([y(1:0)]) + call i ([p(1:0)]) + call j ([t0]) + call j ([t0,t0]) + call j ([t1]) + call j ([tt]) + call j ([tt,tt]) + call j ([t1(1:0)]) + call j ([tt(1:0)]) + end subroutine a2 + ! + subroutine a3 () + print *, "Array constructor with type-spec as actual argument" + call i ([real:: ]) + call i ([real:: 7]) + call i ([real:: m]) + call i ([real:: n]) + call i ([real:: x]) + call i ([real:: w]) + call i ([real:: m(1:0)]) + call i ([real:: n(1:0)]) + call i ([real:: m,n(1:0)]) + call i ([real:: x(1:0)]) + call i ([real:: w(1:0)]) + call i ([real:: z(1:0)]) + call i ([real:: y]) + call i ([real:: p]) + call i ([real:: y,y]) + call i ([real:: p,p]) + call i ([real:: y(1:0)]) + call i ([real:: p(1:0)]) + call j ([ dt :: ]) + call j ([ dt :: t0]) + call j ([ dt :: t0,t0]) + call j ([ dt :: t1]) + call j ([ dt :: tt]) + call j ([ dt :: tt,tt]) + call j ([ dt :: t1(1:0)]) + call j ([ dt :: tt(1:0)]) + end subroutine a3 + ! + subroutine i (arg) + real, optional, intent(in) :: arg(:) + logical :: t + t =3D present (arg) + k =3D k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l =3D l + 1 + if (.not. t) stop k + end subroutine i + ! + subroutine j (arg) + type(dt), optional, intent(in) :: arg(:) + logical :: t + t =3D present (arg) + k =3D k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l =3D l + 1 + if (.not. t) stop k + end subroutine j + ! + subroutine all_missing (arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8) + real, optional, intent(in) :: arg1(:) + real, optional, allocatable :: arg2(:) + real, optional, pointer :: arg3(:) + character(*), optional, intent(in) :: arg4(:) + character(*), optional, allocatable :: arg5(:) + character(*), optional, pointer :: arg6(:) + character(:), optional, pointer :: arg7(:) + character(:), optional, allocatable :: arg8(:) + if (present (arg1)) stop 101 + if (present (arg2)) stop 102 + if (present (arg3)) stop 103 + if (present (arg4)) stop 104 + if (present (arg5)) stop 105 + if (present (arg6)) stop 106 + if (present (arg7)) stop 107 + if (present (arg8)) stop 108 + end subroutine all_missing +end program diff --git a/gcc/testsuite/gfortran.dg/zero_sized_15.f90 b/gcc/testsuite/g= fortran.dg/zero_sized_15.f90 new file mode 100644 index 00000000000..c7d12ae7173 =2D-- /dev/null +++ b/gcc/testsuite/gfortran.dg/zero_sized_15.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! PR fortran/86277 +! +! Check proper detection of presence of optional array dummy arguments +! for zero-sized actual array arguments or array constructors: +! tests for CHARACTER + +program test + implicit none + character(0), parameter :: c0(0) =3D "" + character(0), parameter :: c1(1) =3D "" + character(1), parameter :: d0(0) =3D "" + character(1), parameter :: d1(1) =3D "" + character(0) :: w0(0) + character(0) :: w1(1) + character(:), allocatable :: cc(:) + integer :: k =3D 0, l =3D 0 ! Test/failure counte= r + ! + allocate (character(0) :: cc(0)) + call a0 () + call a1 () + call a2 () + call a3 () + print *, "Total tests:", k, " failed:", l +contains + subroutine a0 () + print *, "Variables as actual argument" + call i (c0) + call i (c1) + call i (d0) + call i (d1) + call i (w0) + call i (w1) + call i (cc) + print *, "Array section as actual argument" + call i (c1(1:0)) + call i (c1(1:0)(1:0)) + call i (w1(1:0)) + call i (w1(1:0)(1:0)) + call i (cc(1:0)) + call i (cc(1:0)(1:0)) + end subroutine a0 + ! + subroutine a1 () + print *, "Explicit temporary as actual argument" + call i ((c0)) + call i ((c1)) + call i ((d0)) + call i ((d1)) + call i ((w0)) + call i ((w1)) + call i ((cc)) + call i ((c1(1:0))) + call i ((c1(1:0)(1:0))) + call i ((w1(1:0))) + call i ((w1(1:0)(1:0))) + call i ((cc(1:0))) + call i ((cc(1:0)(1:0))) + end subroutine a1 + ! + subroutine a2 () + print *, "Array constructor as actual argument" + call i ([c0]) + call i ([c1]) + call i ([d0]) + call i ([d1]) + call i ([w0]) + call i ([w1]) + call i ([cc]) + call i ([c0,c0]) + call i ([c1,c1]) + call i ([d0,d0]) + call i ([cc,cc]) + call i ([c1(1:0)]) + call i ([c1(1:0)(1:0)]) + call i ([w1(1:0)]) + call i ([w1(1:0)(1:0)]) + call i ([cc(1:0)]) + call i ([cc(1:0)(1:0)]) + end subroutine a2 + ! + subroutine a3 () + print *, "Array constructor with type-spec as actual argument" + call i ([character(0) :: ]) + call i ([character(0) :: ""]) + call i ([character(0) :: c0]) + call i ([character(0) :: c1]) + call i ([character(0) :: d0]) + call i ([character(0) :: d1]) + call i ([character(0) :: w0]) + call i ([character(0) :: w1]) + call i ([character(0) :: cc]) + call i ([character(0) :: c0,c0]) + call i ([character(0) :: c1,c1]) + call i ([character(0) :: d0,d0]) + call i ([character(0) :: cc,cc]) + call i ([character(0) :: c1(1:0)]) + call i ([character(0) :: c1(1:0)(1:0)]) + call i ([character(0) :: w1(1:0)]) + call i ([character(0) :: w1(1:0)(1:0)]) + call i ([character(0) :: cc(1:0)]) + call i ([character(0) :: cc(1:0)(1:0)]) + end subroutine a3 + ! + subroutine i(arg) + character(*), optional, intent(in) :: arg(:) + logical :: t + t =3D present (arg) + k =3D k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l =3D l + 1 + if (.not. t) stop k + end subroutine i +end program =2D- 2.35.3 --rekceb-52f1e595-8664-425d-85b4-8b559772601f--