Skip to content

R
riscv-gcc-1
Commit c41fea4a by Paul Thomas
Options

re PR fortran/34955 (transfer_assumed_size_1.f90: Valgrind error: invalid read of size 3) 

2009-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34955
	* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has
	been absorbed into gfc_conv_intrinsic_transfer. All
	references to it in trans-intrinsic.c have been changed
	accordingly.  PR fixed by using a temporary for scalar
	character transfer, when the source is shorter than the
	destination.

2009-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34955
	* gfortran.dg/transfer_intrinsic_1.f90: New test.
	* gfortran.dg/transfer_intrinsic_2.f90: New test.

From-SVN: r143462
parent 6e7ff326
Showing with 154 additions and 87 deletions
gcc/fortran/ChangeLog
2009-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34955
* trans-intrinsic.c (gfc_conv_intrinsic_array_transfer): Has
been absorbed into gfc_conv_intrinsic_transfer. All
references to it in trans-intrinsic.c have been changed
accordingly. PR fixed by using a temporary for scalar
character transfer, when the source is shorter than the
destination.
2009-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38657
* module.c (write_common_0): Revert patch of 2009-01-05.
......
gcc/fortran/trans-intrinsic.c
......@@ -3615,18 +3615,27 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
}
/* Array transfer statement.
DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
where:
typeof<DEST> = typeof<MOLD>
and:
N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
/* Generate code for the TRANSFER intrinsic:
For scalar results:
DEST = TRANSFER (SOURCE, MOLD)
where:
typeof<DEST> = typeof<MOLD>
and:
MOLD is scalar.
For array results:
DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
where:
typeof<DEST> = typeof<MOLD>
and:
N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
sizeof (DEST(0) * SIZE). */
static void
gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
tree tmp;
tree tmpdecl;
tree ptr;
tree extent;
tree source;
tree source_type;
......@@ -3645,14 +3654,27 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
gfc_ss_info *info;
stmtblock_t block;
int n;
bool scalar_mold;
gcc_assert (se->loop);
info = &se->ss->data.info;
info = NULL;
if (se->loop)
info = &se->ss->data.info;
/* Convert SOURCE. The output from this stage is:-
source_bytes = length of the source in bytes
source = pointer to the source data. */
arg = expr->value.function.actual;
/* Ensure double transfer through LOGICAL preserves all
the needed bits. */
if (arg->expr->expr_type == EXPR_FUNCTION
&& arg->expr->value.function.esym == NULL
&& arg->expr->value.function.isym != NULL
&& arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
&& arg->expr->ts.type == BT_LOGICAL
&& expr->ts.type != arg->expr->ts.type)
arg->expr->value.function.name = "__transfer_in_transfer";
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
......@@ -3682,8 +3704,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Repack the source if not a full variable array. */
if (!(arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->ref->u.ar.type == AR_FULL))
if (arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->ref->u.ar.type != AR_FULL)
{
tmp = build_fold_addr_expr (argse.expr);
......@@ -3750,6 +3772,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
scalar_mold = arg->expr->rank == 0;
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
......@@ -3763,6 +3787,9 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
{
/* If this TRANSFER is nested in another TRANSFER, use a type
......@@ -3799,14 +3826,14 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
else
tmp = NULL_TREE;
/* Separate array and scalar results. */
if (scalar_mold && tmp == NULL_TREE)
goto scalar_transfer;
size_bytes = gfc_create_var (gfc_array_index_type, NULL);
if (tmp != NULL_TREE)
{
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
tmp, dest_word_len);
tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
tmp, source_bytes);
}
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
tmp, dest_word_len);
else
tmp = source_bytes;
......@@ -3847,9 +3874,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
se->loop->to[n] = upper;
/* Build a destination descriptor, using the pointer, source, as the
data field. This is already allocated so set callee_alloc.
FIXME callee_alloc is not set! */
data field. */
gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
info, mold_type, NULL_TREE, false, true, false,
&expr->where);
......@@ -3863,72 +3888,71 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3,
tmp,
fold_convert (pvoid_type_node, source),
size_bytes);
fold_build2 (MIN_EXPR, gfc_array_index_type,
size_bytes, source_bytes));
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = info->descriptor;
if (expr->ts.type == BT_CHARACTER)
se->string_length = dest_word_len;
}
return;
/* Scalar transfer statement.
TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
/* Deal with scalar results. */
scalar_transfer:
extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
dest_word_len, source_bytes);
static void
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
gfc_actual_arglist *arg;
gfc_se argse;
tree type;
tree ptr;
gfc_ss *ss;
tree tmpdecl, tmp;
if (expr->ts.type == BT_CHARACTER)
{
tree direct;
tree indirect;
/* Get a pointer to the source. */
arg = expr->value.function.actual;
ss = gfc_walk_expr (arg->expr);
gfc_init_se (&argse, NULL);
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (&argse, arg->expr);
else
gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
ptr = argse.expr;
ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
"transfer");
arg = arg->next;
type = gfc_typenode_for_spec (&expr->ts);
if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
{
/* If this TRANSFER is nested in another TRANSFER, use a type
that preserves all bits. */
if (expr->ts.type == BT_LOGICAL)
type = gfc_get_int_type (expr->ts.kind);
}
/* If source is longer than the destination, use a pointer to
the source directly. */
gfc_init_block (&block);
gfc_add_modify (&block, tmpdecl, ptr);
direct = gfc_finish_block (&block);
if (expr->ts.type == BT_CHARACTER)
{
ptr = convert (build_pointer_type (type), ptr);
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, arg->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
se->expr = ptr;
se->string_length = argse.string_length;
/* Otherwise, allocate a string with the length of the destination
and copy the source into it. */
gfc_init_block (&block);
tmp = gfc_get_pchar_type (expr->ts.kind);
tmp = gfc_call_malloc (&block, tmp, dest_word_len);
gfc_add_modify (&block, tmpdecl,
fold_convert (TREE_TYPE (ptr), tmp));
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmpdecl),
fold_convert (pvoid_type_node, ptr),
extent);
gfc_add_expr_to_block (&block, tmp);
indirect = gfc_finish_block (&block);
/* Wrap it up with the condition. */
tmp = fold_build2 (LE_EXPR, boolean_type_node,
dest_word_len, source_bytes);
tmp = build3_v (COND_EXPR, tmp, direct, indirect);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = tmpdecl;
se->string_length = dest_word_len;
}
else
{
tree moldsize;
tmpdecl = gfc_create_var (type, "transfer");
moldsize = size_in_bytes (type);
tmpdecl = gfc_create_var (mold_type, "transfer");
ptr = convert (build_pointer_type (mold_type), source);
/* Use memcpy to do the transfer. */
tmp = build_fold_addr_expr (tmpdecl);
tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
moldsize);
extent);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = tmpdecl;
......@@ -4828,23 +4852,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_advance_se_ss_chain (se);
}
else
{
/* Ensure double transfer through LOGICAL preserves all
the needed bits. */
gfc_expr *source = expr->value.function.actual->expr;
if (source->expr_type == EXPR_FUNCTION
&& source->value.function.esym == NULL
&& source->value.function.isym != NULL
&& source->value.function.isym->id == GFC_ISYM_TRANSFER
&& source->ts.type == BT_LOGICAL
&& expr->ts.type != source->ts.type)
source->value.function.name = "__transfer_in_transfer";
if (se->ss)
gfc_conv_intrinsic_array_transfer (se, expr);
else
gfc_conv_intrinsic_transfer (se, expr);
}
gfc_conv_intrinsic_transfer (se, expr);
break;
case GFC_ISYM_TTYNAM:
......
gcc/testsuite/ChangeLog
2009-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34955
* gfortran.dg/transfer_intrinsic_1.f90: New test.
* gfortran.dg/transfer_intrinsic_2.f90: New test.
2009-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38657
* gfortran.dg/module_commons_3.f90: Remove
......
gcc/testsuite/gfortran.dg/char_cast_1.f90
......@@ -25,7 +25,7 @@
return
end function Upper
end
! The sign that all is well is that [S.5][1] appears twice.
! Platform dependent variations are [S$5][1], [__S_5][1], [S___5][1]
! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 2 "original" } }
! The sign that all is well is that [S.6][1] appears twice.
! Platform dependent variations are [S$6][1], [__S_6][1], [S___6][1]
! { dg-final { scan-tree-dump-times "6\\\]\\\[1\\\]" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
gcc/testsuite/gfortran.dg/transfer_intrinsic_1.f90 0 → 100644
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! Check the fix for PR34955 in which three bytes would be copied
! from bytes by TRANSFER, instead of the required two.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
subroutine BytesToString(bytes, string)
type ByteType
integer(kind=1) :: singleByte
end type
type (ByteType) :: bytes(2)
character(len=*) :: string
string = transfer(bytes, string)
end subroutine
! { dg-final { scan-tree-dump-times "MIN_EXPR" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
gcc/testsuite/gfortran.dg/transfer_intrinsic_2.f90 0 → 100644
! { dg-do run }
!
! Check the fix for PR34955 in which three bytes would be copied
! from bytes by TRANSFER, instead of the required two and the
! resulting string length would be incorrect.
!
! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
!
character(len = 1) :: string = "z"
character(len = 20) :: tmp = ""
tmp = Upper ("abcdefgh")
if (trim(tmp) .ne. "ab") call abort ()
contains
Character (len = 20) Function Upper (string)
Character(len = *) string
integer :: ij
i = size (transfer (string,"xy",len (string)))
if (i /= len (string)) call abort ()
Upper = ""
Upper(1:2) = &
transfer (merge (transfer (string,"xy",len (string)), &
string(1:2), .true.), "xy")
return
end function Upper
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment