From 9a14c44d46d12a49b3e1cde59dd235a7a44b02b6 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 7 Dec 2010 21:29:22 +0100 Subject: [PATCH] re PR fortran/44352 (ICE in string_to_single_character) 2010-12-07 Tobias Burnus 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 PR fortran/44352 * gfortran.dg/string_4.f90: New. From-SVN: r167569 --- gcc/fortran/ChangeLog | 11 ++++++ gcc/fortran/trans-expr.c | 47 ++++++++++++++---------- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/string_4.f90 | 51 ++++++++++++++++++++++++++ 4 files changed, 94 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/string_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a1d06c5872f..957ee8be97c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2010-12-07 Tobias Burnus + + 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 PR fortran/46794 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 46f80f7fb17..72a7c2c9015 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); + + 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, tmp, fsym->ts.kind, + 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 96275ed6d29..c2016451054 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-12-07 Tobias Burnus + + PR fortran/44352 + * gfortran.dg/string_4.f90: New. + 2010-12-07 Sebastian Pop PR tree-optimization/44676 diff --git a/gcc/testsuite/gfortran.dg/string_4.f90 b/gcc/testsuite/gfortran.dg/string_4.f90 new file mode 100644 index 00000000000..12f501bb9ab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/string_4.f90 @@ -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 -- 2.30.2