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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a1d06c5872fed8979b78b9f93a29c465af3ee0ed..957ee8be97c59f067df2ea6c7ae01093c44631c0 100644 (file)
--- 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 46f80f7fb1733b3e7a0e4f2c2fb9afdfd1a11be2..72a7c2c9015ec685b8cdc54c1ecf1dcd58513485 100644 (file)
--- 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 96275ed6d2911dbce24bf32b4eb8976bcdbd68df..c2016451054660868709e41bdea8c00628495a90 100644 (file)
--- 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 (file)
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