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

4 files changed, 94 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a1d06c5..957ee8b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 46f80f7..72a7c2c 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 96275ed..c201645 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/string_4.f90 b/gcc/testsuite/gfortran.dg/string_4.f90
new file mode 100644
index 0000000..12f501b
--- /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