OSDN Git Service

2010-12-07 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 7 Dec 2010 20:29:22 +0000 (20:29 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 7 Dec 2010 20:29:22 +0000 (20:29 +0000)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@167569 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/trans-expr.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/string_4.f90 [new file with mode: 0644]

index a1d06c5..957ee8b 100644 (file)
@@ -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
index 46f80f7..72a7c2c 100644 (file)
@@ -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);
index 96275ed..c201645 100644 (file)
@@ -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
@@ -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