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