public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-6604] Fortran: fix ICE and wrong code with TRANSFER and CHARACTER(kind=4)
@ 2022-01-15 21:35 Harald Anlauf
0 siblings, 0 replies; only message in thread
From: Harald Anlauf @ 2022-01-15 21:35 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:29401b7b4581e9131e7057e263dcea8b40a6b5ab
commit r12-6604-g29401b7b4581e9131e7057e263dcea8b40a6b5ab
Author: Harald Anlauf <anlauf@gmx.de>
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.
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 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 dc72d994781..a7cbbebdd6f 100644
--- 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
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
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-01-15 21:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-01-15 21:35 [gcc r12-6604] Fortran: fix ICE and wrong code with TRANSFER and CHARACTER(kind=4) Harald Anlauf
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).