From patchwork Mon Jun 12 21:12:45 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1794157 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=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=cj8ULLiB; dkim-atps=neutral Received: from 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 4Qg4Cr10nvz20QH for ; Tue, 13 Jun 2023 07:13:11 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id E65823857C43 for ; Mon, 12 Jun 2023 21:13:08 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E65823857C43 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1686604388; bh=p8LyBahN1awMPvGQaRLqwimYv8W2ZAjz6ZQS0Uh2ra0=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=cj8ULLiBZeHJZ5PqdkI+zkpiYlbcQXKN4/ni+cG1Zcxp/aj3Cofhm7DXKPyrsG+kf p687mn84ieakuhI5KGkLDAL2JYLF6IcnRuRvW0O6BPNGZnevfg/Usp73SwwIinPFVR CFE9Xs51dsJCQGmlY+UbJN7qVVNIu3BaB56AVbRE= 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.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 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: To: fortran , gcc-patches Subject: [PATCH] Fortran: fix passing of zero-sized array arguments to procedures [PR86277] 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 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, 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 From 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 (= 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 --- 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 --- 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 = info->descriptor; info->offset = gfc_index_zero_node; - if (size == NULL_TREE || integer_zerop (size)) + if (size == 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/gfortran.dg/zero_sized_14.f90 new file mode 100644 index 00000000000..32c7ae28e3a --- /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) = 42. + real, parameter :: n(1) = 23. + real :: x(0) = 1. + real :: z(1) = 2. + real :: w(0) + real, pointer :: p(:) + real, allocatable :: y(:) + integer :: k = 0, l = 0 ! Test/failure counter + type dt + ! Empty type + end type dt + type(dt), parameter :: t0(0) = dt() + type(dt), parameter :: t1(1) = dt() + type(dt) :: t2(0) = dt() + type(dt) :: t3(1) = 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 = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = l + 1 + if (.not. t) stop k + end subroutine i + ! + subroutine j (arg) + type(dt), optional, intent(in) :: arg(:) + logical :: t + t = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = 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/gfortran.dg/zero_sized_15.f90 new file mode 100644 index 00000000000..c7d12ae7173 --- /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) = "" + character(0), parameter :: c1(1) = "" + character(1), parameter :: d0(0) = "" + character(1), parameter :: d1(1) = "" + character(0) :: w0(0) + character(0) :: w1(1) + character(:), allocatable :: cc(:) + integer :: k = 0, l = 0 ! Test/failure counter + ! + 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 = present (arg) + k = k + 1 + print *, 'test', k, merge (" ok", "FAIL", t) + if (.not. t) l = l + 1 + if (.not. t) stop k + end subroutine i +end program -- 2.35.3