From cb14e9a1975bc9d9d2f544c314a0820f68b8bdc7 Mon Sep 17 00:00:00 2001 From: Harald Anlauf 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