From ccf94ab2abb6969c04d51c7879f07edfbb97ae55 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
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.
(cherry picked from commit 95ddd2659849a904509067ec3a2770135149a722)
---
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 09cdd9263c4e..bc9aba982d8a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7486,7 +7486,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 000000000000..8a5a8c5daf81
--- /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
--
GitLab