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.
This commit is contained in:
Harald Anlauf
parent
52d2821038
commit
29401b7b45
@ -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);
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
{
|
||||
|
||||
115
gcc/testsuite/gfortran.dg/transfer_char_kind4.f90
Normal file
115
gcc/testsuite/gfortran.dg/transfer_char_kind4.f90
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user