diff mbox series

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

Message ID trinity-765c74d7-b1c4-4db3-a3ed-683cddd99750-1641935832234@3c-app-gmx-bs15
State New
Headers
Series PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4) |

Commit Message

Harald Anlauf Jan. 11, 2022, 9:17 p.m. UTC 
  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

Comments

Harald Anlauf Jan. 15, 2022, 8:50 p.m. UTC | #1 
An early *ping* ...

Am 11.01.22 um 22:17 schrieb Harald Anlauf via Fortran:
> 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
>
Thomas Koenig Jan. 15, 2022, 9:28 p.m. UTC | #2 
Hi Harald,

> An early *ping* ...

OK.  Thanks for the patch!

Best regards

	Thomas
diff mbox series

Patch

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