re PR fortran/44352 (ICE in string_to_single_character)
2010-12-07 Tobias Burnus <burnus@net-b.de> PR fortran/44352 * trans-expr.c (gfc_string_to_single_character): Return if not POINTER_TYPE_P. (gfc_trans_string_copy): gfc_build_addr_expr if src or dest is not a pointer. (gfc_trans_string_copy): Make sure the argument string type has a string length, fix indention, and remove not needed gfc_build_addr_expr. 2010-12-07 Tobias Burnus <burnus@net-b.de> PR fortran/44352 * gfortran.dg/string_4.f90: New. From-SVN: r167569
This commit is contained in:
parent
f28ca2b999
commit
9a14c44d46
|
@ -1,3 +1,14 @@
|
|||
2010-12-07 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/44352
|
||||
* trans-expr.c (gfc_string_to_single_character): Return if not
|
||||
POINTER_TYPE_P.
|
||||
(gfc_trans_string_copy): gfc_build_addr_expr if src or dest is
|
||||
not a pointer.
|
||||
(gfc_trans_string_copy): Make sure the argument string type
|
||||
has a string length, fix indention, and remove not needed
|
||||
gfc_build_addr_expr.
|
||||
|
||||
2010-12-04 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/46794
|
||||
|
|
|
@ -1438,9 +1438,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
|
|||
tree
|
||||
gfc_string_to_single_character (tree len, tree str, int kind)
|
||||
{
|
||||
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
|
||||
|
||||
if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
|
||||
if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
|
||||
|| !POINTER_TYPE_P (TREE_TYPE (str)))
|
||||
return NULL_TREE;
|
||||
|
||||
if (TREE_INT_CST_LOW (len) == 1)
|
||||
|
@ -3826,12 +3826,12 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
|
|||
fold_convert (size_type_node,
|
||||
TYPE_SIZE_UNIT (chartype)));
|
||||
|
||||
if (dlength)
|
||||
if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
|
||||
dest = fold_convert (pvoid_type_node, dest);
|
||||
else
|
||||
dest = gfc_build_addr_expr (pvoid_type_node, dest);
|
||||
|
||||
if (slength)
|
||||
if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
|
||||
src = fold_convert (pvoid_type_node, src);
|
||||
else
|
||||
src = gfc_build_addr_expr (pvoid_type_node, src);
|
||||
|
@ -3906,35 +3906,42 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
|
|||
gcc_assert (fargs->sym->attr.dimension == 0);
|
||||
fsym = fargs->sym;
|
||||
|
||||
/* Create a temporary to hold the value. */
|
||||
type = gfc_typenode_for_spec (&fsym->ts);
|
||||
temp_vars[n] = gfc_create_var (type, fsym->name);
|
||||
|
||||
if (fsym->ts.type == BT_CHARACTER)
|
||||
{
|
||||
/* Copy string arguments. */
|
||||
tree arglen;
|
||||
tree arglen;
|
||||
|
||||
gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
|
||||
gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
|
||||
&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
|
||||
|
||||
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
|
||||
tmp = gfc_build_addr_expr (build_pointer_type (type),
|
||||
temp_vars[n]);
|
||||
/* Create a temporary to hold the value. */
|
||||
if (fsym->ts.u.cl->backend_decl == NULL_TREE)
|
||||
fsym->ts.u.cl->backend_decl
|
||||
= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
|
||||
|
||||
gfc_conv_expr (&rse, args->expr);
|
||||
gfc_conv_string_parameter (&rse);
|
||||
gfc_add_block_to_block (&se->pre, &lse.pre);
|
||||
gfc_add_block_to_block (&se->pre, &rse.pre);
|
||||
type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
|
||||
temp_vars[n] = gfc_create_var (type, fsym->name);
|
||||
|
||||
gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
|
||||
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
|
||||
|
||||
gfc_conv_expr (&rse, args->expr);
|
||||
gfc_conv_string_parameter (&rse);
|
||||
gfc_add_block_to_block (&se->pre, &lse.pre);
|
||||
gfc_add_block_to_block (&se->pre, &rse.pre);
|
||||
|
||||
gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
|
||||
rse.string_length, rse.expr, fsym->ts.kind);
|
||||
gfc_add_block_to_block (&se->pre, &lse.post);
|
||||
gfc_add_block_to_block (&se->pre, &rse.post);
|
||||
gfc_add_block_to_block (&se->pre, &lse.post);
|
||||
gfc_add_block_to_block (&se->pre, &rse.post);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* For everything else, just evaluate the expression. */
|
||||
|
||||
/* Create a temporary to hold the value. */
|
||||
type = gfc_typenode_for_spec (&fsym->ts);
|
||||
temp_vars[n] = gfc_create_var (type, fsym->name);
|
||||
|
||||
gfc_conv_expr (&lse, args->expr);
|
||||
|
||||
gfc_add_block_to_block (&se->pre, &lse.pre);
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2010-12-07 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/44352
|
||||
* gfortran.dg/string_4.f90: New.
|
||||
|
||||
2010-12-07 Sebastian Pop <sebastian.pop@amd.com>
|
||||
|
||||
PR tree-optimization/44676
|
||||
|
|
|
@ -0,0 +1,51 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "" }
|
||||
! (options to disable warnings about statement functions etc.)
|
||||
!
|
||||
! PR fortran/44352
|
||||
!
|
||||
! Contributed by Vittorio Zecca
|
||||
!
|
||||
|
||||
SUBROUTINE TEST1()
|
||||
implicit real*8 (a-h,o-z)
|
||||
character*32 ddname,stmtfnt1
|
||||
stmtfnt1(x)= 'h810 e=0.01 '
|
||||
ddname=stmtfnt1(0.d0)
|
||||
if (ddname /= "h810 e=0.01") call abort()
|
||||
END
|
||||
|
||||
SUBROUTINE TEST2()
|
||||
implicit none
|
||||
character(2) :: ddname,stmtfnt2
|
||||
real :: x
|
||||
stmtfnt2(x)= 'x'
|
||||
ddname=stmtfnt2(0.0)
|
||||
if(ddname /= 'x') call abort()
|
||||
END
|
||||
|
||||
SUBROUTINE TEST3()
|
||||
implicit real*8 (a-h,o-z)
|
||||
character*32 ddname,dname
|
||||
character*2 :: c
|
||||
dname(c) = 'h810 e=0.01 '
|
||||
ddname=dname("w ")
|
||||
if (ddname /= "h810 e=0.01") call abort()
|
||||
END
|
||||
|
||||
SUBROUTINE TEST4()
|
||||
implicit real*8 (a-h,o-z)
|
||||
character*32 ddname,dname
|
||||
character*2 :: c
|
||||
dname(c) = 'h810 e=0.01 '
|
||||
c = 'aa'
|
||||
ddname=dname("w ")
|
||||
if (ddname /= "h810 e=0.01") call abort()
|
||||
if (c /= "aa") call abort()
|
||||
END
|
||||
|
||||
call test1()
|
||||
call test2()
|
||||
call test3()
|
||||
call test4()
|
||||
end
|
Loading…
Reference in New Issue