diff mbox series

Fortran: intrinsics and deferred-length character arguments [PR95947,PR110658]

Message ID trinity-442fa3d0-10b8-415b-a161-a5821d474fdb-1689539459265@3c-app-gmx-bap40
State New
Headers show
Series Fortran: intrinsics and deferred-length character arguments [PR95947,PR110658] | expand

Commit Message

Harald Anlauf July 16, 2023, 8:30 p.m. UTC 
Dear all,

some intrinsics may return character results with the same
characteristics as their first argument (e.g. PACK, MINVAL, ...).
If the first argument is of deferred-length, we need to derive
the character length of the result from the first argument, like
in the assumed-length case, but we must not handle it as
deferred-length, as that has a different argument passing
convention.

The attached - almost trivial and obvious - patch fixes that.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

As this is a rather simple fix for a wrong-code bug, I would
like to backport this at least to 13-branch, unless there
are major concerns.

Thanks,
Harald

Comments

Li, Pan2 via Gcc-patches July 16, 2023, 9:53 p.m. UTC | #1 
On Sun, Jul 16, 2023 at 10:30:59PM +0200, Harald Anlauf via Fortran wrote:
> Dear all,
> 
> some intrinsics may return character results with the same
> characteristics as their first argument (e.g. PACK, MINVAL, ...).
> If the first argument is of deferred-length, we need to derive
> the character length of the result from the first argument, like
> in the assumed-length case, but we must not handle it as
> deferred-length, as that has a different argument passing
> convention.
> 
> The attached - almost trivial and obvious - patch fixes that.
> 
> Regtested on x86_64-pc-linux-gnu.  OK for mainline?
> 
> As this is a rather simple fix for a wrong-code bug, I would
> like to backport this at least to 13-branch, unless there
> are major concerns.
>

OK for trunk and backports.
diff mbox series

Patch

From 88d2694eb1278b0ad0d542565e0542c39fe6b466 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.
---
 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 dbb04f8c434..d1570b31a82 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7654,7 +7654,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 00000000000..8a5a8c5daf8
--- /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
--
2.35.3