From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 168FC3858C39; Sun, 23 Jan 2022 19:39:39 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 168FC3858C39 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r11-9487] Fortran: fix ICE and wrong code with TRANSFER and CHARACTER(kind=4) X-Act-Checkin: gcc X-Git-Author: Harald Anlauf X-Git-Refname: refs/heads/releases/gcc-11 X-Git-Oldrev: 8adfe466f5573fadd155bfb688e9af4368139e13 X-Git-Newrev: a8c234519366b9a93a4bbc0717d609de27ccdc0e Message-Id: <20220123193939.168FC3858C39@sourceware.org> Date: Sun, 23 Jan 2022 19:39:39 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Sun, 23 Jan 2022 19:39:39 -0000 https://gcc.gnu.org/g:a8c234519366b9a93a4bbc0717d609de27ccdc0e commit r11-9487-ga8c234519366b9a93a4bbc0717d609de27ccdc0e Author: Harald Anlauf Date: Tue Jan 11 22:06:10 2022 +0100 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. (cherry picked from commit 29401b7b4581e9131e7057e263dcea8b40a6b5ab) Diff: --- gcc/fortran/target-memory.c | 2 +- gcc/fortran/trans-intrinsic.c | 17 +++- gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 | 115 ++++++++++++++++++++++ 3 files changed, 130 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 7b21a9e04e8..441ba1d986c 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -486,7 +486,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 ab9232dd7b0..40dc983b751 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8656,7 +8656,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); @@ -8758,7 +8759,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; @@ -8812,7 +8819,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