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.

diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c
index af1c210..9b5af8d 100644 (file)
--- 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 dc72d99..a7cbbeb 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8533,7 +8533,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);
@@ -8635,7 +8636,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;
 
@@ -8689,7 +8696,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 (file)
index 0000000..5f1fe69
--- /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