[PATCH] PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4)

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 798 bytes --]

Dear Fortranners,

when digging into the issue pointed out in the PR by Gerhard it turned
out that there were several issues with the TRANSFER intrinsics in the
case MOLD was CHARACTER(kind=4).  Default CHARACTER was fine, though.

- the size of the result was wrongly calculated
- the string length used in temporaries was wrong
- the result characteristics was wrong

Fortunately, the few fixes were very local and needed only fix-ups of
the respective computations.

Since the details of which issue would show up seemed to depend on the
properties of a the arguments to TRANSFER, I wrote an extended testcase
which is a "hull" of what I used in debugging.

(The testcase was and can be cross-checked with the NAG compiler.)

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

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fortran-fix-ICE-and-wrong-code-with-TRANSFER-and-CHA.patch --]
[-- Type: text/x-patch, Size: 8590 bytes --]

From cb14e9a1975bc9d9d2f544c314a0820f68b8bdc7 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 11 Jan 2022 22:06:10 +0100
Subject: [PATCH] Fortran: fix ICE and wrong code with TRANSFER and
 CHARACTER(kind=4)

gcc/fortran/ChangeLog:

	PR fortran/83079
	* target-memory.c (gfc_interpret_character): Result length is
	in bytes and thus depends on the character kind.
	* trans-intrinsic.c (gfc_conv_intrinsic_transfer): Compute correct
	string length for the result of the TRANSFER intrinsic and for
	temporaries for the different character kinds.

gcc/testsuite/ChangeLog:

	PR fortran/83079
	* gfortran.dg/transfer_char_kind4.f90: New test.
---
 gcc/fortran/target-memory.c                   |   2 +-
 gcc/fortran/trans-intrinsic.c                 |  17 ++-
 .../gfortran.dg/transfer_char_kind4.f90       | 115 ++++++++++++++++++
 3 files changed, 130 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/transfer_char_kind4.f90

diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index af1c21047f6..9b5af8d1482 100644
--- a/gcc/fortran/target-memory.c
+++ b/gcc/fortran/target-memory.c
@@ -485,7 +485,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size,

   result->value.character.string[result->value.character.length] = '\0';

-  return result->value.character.length;
+  return size_character (result->value.character.length, result->ts.kind);
 }


diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index aae34b06948..5821b2264ce 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8531,7 +8531,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
     {
     case BT_CHARACTER:
       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
-      mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+      mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
+					      argse.string_length);
       break;
     case BT_CLASS:
       tmp = gfc_class_vtab_size_get (argse.expr);
@@ -8633,7 +8634,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)

   se->expr = info->descriptor;
   if (expr->ts.type == BT_CHARACTER)
-    se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
+    {
+      tmp = fold_convert (gfc_charlen_type_node,
+			  TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
+      se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+					   gfc_charlen_type_node,
+					   dest_word_len, tmp);
+    }

   return;

@@ -8687,7 +8694,11 @@ scalar_transfer:
       gfc_add_expr_to_block (&se->post, tmp);

       se->expr = tmpdecl;
-      se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
+      tmp = fold_convert (gfc_charlen_type_node,
+			  TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
+      se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+					   gfc_charlen_type_node,
+					   dest_word_len, tmp);
     }
   else
     {
diff --git a/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 b/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90
new file mode 100644
index 00000000000..5f1fe691318
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90
@@ -0,0 +1,115 @@
+! { dg-do run }
+! PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4)
+! Exercise TRANSFER intrinsic to check character result length and shape
+
+program p
+  implicit none
+  character(len=*,kind=4), parameter :: a = 4_'ABCDEF'
+  character(len=6,kind=4)            :: b = 4_'abcdef'
+  character(len=*,kind=4), parameter :: c = 4_'XY'
+  character(len=2,kind=4)            :: d = 4_'xy'
+  integer :: k, l
+  k = len (a)
+  l = len (c)
+
+! print *, transfer(4_'xy', [4_'a'])
+
+  ! TRANSFER with rank-0 result
+  call chk0 (transfer (4_'ABCD', 4_'XY'), 2, 1)
+  call chk0 (transfer (4_'ABCD', c     ), l, 2)
+  call chk0 (transfer (4_'ABCD', d     ), l, 3)
+  call chk0 (transfer (a       , 4_'XY'), 2, 4)
+  call chk0 (transfer (a       , c     ), l, 5)
+  call chk0 (transfer (a       , d     ), l, 6)
+  call chk0 (transfer (b       , 4_'XY'), 2, 7)
+  call chk0 (transfer (b       , c     ), l, 8)
+  call chk0 (transfer (b       , d     ), l, 9)
+
+  call chk0 (transfer ([4_'ABCD'], 4_'XY'), 2, 11)
+  call chk0 (transfer ([4_'ABCD'], c     ), l, 12)
+  call chk0 (transfer ([4_'ABCD'], d     ), l, 13)
+  call chk0 (transfer ([a       ], 4_'XY'), 2, 14)
+  call chk0 (transfer ([a       ], c     ), l, 15)
+  call chk0 (transfer ([a       ], d     ), l, 16)
+  call chk0 (transfer ([b       ], 4_'XY'), 2, 17)
+  call chk0 (transfer ([b       ], c     ), l, 18)
+  call chk0 (transfer ([b       ], d     ), l, 19)
+
+  ! TRANSFER with rank-1 result
+  call chk1 (transfer (4_'ABCD', [4_'XY']), 2,   2, 21)
+  call chk1 (transfer (4_'ABCD', [c]     ), 2,   2, 22)
+  call chk1 (transfer (4_'ABCD', [d]     ), 2,   2, 23)
+  call chk1 (transfer (a       , [4_'XY']), 2, k/2, 24)
+  call chk1 (transfer (a       , [c]     ), l, k/l, 25)
+  call chk1 (transfer (a       , [d]     ), l, k/l, 26)
+  call chk1 (transfer (b       , [4_'XY']), 2, k/2, 27)
+  call chk1 (transfer (b       , [c]     ), l, k/l, 28)
+  call chk1 (transfer (b       , [d]     ), l, k/l, 29)
+
+  call chk1 (transfer (4_'ABCD', 4_'XY',size=2), 2, 2, 31)
+  call chk1 (transfer (4_'ABCD', c     ,size=2), 2, 2, 32)
+  call chk1 (transfer (4_'ABCD', d     ,size=2), 2, 2, 33)
+  call chk1 (transfer (a       , 4_'XY',size=3), 2, 3, 34)
+  call chk1 (transfer (a       , c     ,size=3), l, 3, 35)
+  call chk1 (transfer (a       , d     ,size=3), l, 3, 36)
+  call chk1 (transfer (b       , 4_'XY',size=3), 2, 3, 37)
+  call chk1 (transfer (b       , c     ,size=3), l, 3, 38)
+  call chk1 (transfer (b       , d     ,size=3), l, 3, 39)
+
+  call chk1 (transfer (4_'ABCD', [4_'XY'],size=2), 2, 2, 41)
+  call chk1 (transfer (4_'ABCD', [c]     ,size=2), 2, 2, 42)
+  call chk1 (transfer (4_'ABCD', [d]     ,size=2), 2, 2, 43)
+  call chk1 (transfer (a       , [4_'XY'],size=3), 2, 3, 44)
+  call chk1 (transfer (a       , [c]     ,size=3), l, 3, 45)
+  call chk1 (transfer (a       , [d]     ,size=3), l, 3, 46)
+  call chk1 (transfer (b       , [4_'XY'],size=3), 2, 3, 47)
+  call chk1 (transfer (b       , [c]     ,size=3), l, 3, 48)
+  call chk1 (transfer (b       , [d]     ,size=3), l, 3, 49)
+
+  call chk1 (transfer ([4_'ABCD'], [4_'XY']), 2,   2, 51)
+  call chk1 (transfer ([4_'ABCD'], [c]     ), 2,   2, 52)
+  call chk1 (transfer ([4_'ABCD'], [d]     ), 2,   2, 53)
+  call chk1 (transfer ([a       ], [4_'XY']), 2, k/2, 54)
+  call chk1 (transfer ([a       ], [c]     ), l, k/l, 55)
+  call chk1 (transfer ([a       ], [d]     ), l, k/l, 56)
+  call chk1 (transfer ([b       ], [4_'XY']), 2, k/2, 57)
+  call chk1 (transfer ([b       ], [c]     ), l, k/l, 58)
+  call chk1 (transfer ([b       ], [d]     ), l, k/l, 59)
+
+  call chk1 (transfer (4_'ABCD', c     ,size=4/l), l, 4/l, 62)
+  call chk1 (transfer (4_'ABCD', d     ,size=4/l), l, 4/l, 63)
+  call chk1 (transfer (a       , 4_'XY',size=k/2), 2, k/2, 64)
+  call chk1 (transfer (a       , c     ,size=k/l), l, k/l, 65)
+  call chk1 (transfer (a       , d     ,size=k/l), l, k/l, 66)
+  call chk1 (transfer (b       , 4_'XY',size=k/2), 2, k/2, 67)
+  call chk1 (transfer (b       , c     ,size=k/l), l, k/l, 68)
+  call chk1 (transfer (b       , d     ,size=k/l), l, k/l, 69)
+
+contains
+  ! Validate rank-0 result
+  subroutine chk0 (str, l, stopcode)
+    character(kind=4,len=*), intent(in) :: str
+    integer,                 intent(in) :: l, stopcode
+    integer :: i, p
+    i = len  (str)
+    p = verify (str, a // b) ! Check for junk characters
+    if (i /= l .or. p > 0) then
+       print *, stopcode, "len=", i, i == l, ">", str, "<"
+       stop stopcode
+    end if
+  end subroutine chk0
+
+  ! Validate rank-1 result
+  subroutine chk1 (str, l, m, stopcode)
+    character(kind=4,len=*), intent(in) :: str(:)
+    integer,                 intent(in) :: l, m, stopcode
+    integer :: i, j, p
+    i = len  (str)
+    j = size (str)
+    p = maxval (verify (str, a // b)) ! Check for junk characters
+    if (i /= l .or. j /= m .or. p > 0) then
+       print *, stopcode, "len=", i, i == l, "size=", j, j == m, ">", str, "<"
+       stop stopcode
+    end if
+  end subroutine chk1
+end
--
2.31.1