2011-01-31 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/47519
	* trans-stmt.c (gfc_trans_allocate): Improve handling of
	deferred character lengths with SOURCE.
	* iresolve.c (gfc_resolve_repeat): Calculate character
	length from source length and ncopies.
	* dump-parse-tree.c (show_code_node): Show MOLD and SOURCE
	expressions for ALLOCATE.

2011-01-31  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47519
	* gfortran.dg/allocate_deferred_char_scalar_2.f03: New test.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e146d76..ae08fdc 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2011-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47519
+       * trans-stmt.c (gfc_trans_allocate): Improve handling of
+       deferred character lengths with SOURCE.
+       * iresolve.c (gfc_resolve_repeat): Calculate character
+       length from source length and ncopies.
+       * dump-parse-tree.c (show_code_node): Show MOLD and SOURCE
+       expressions for ALLOCATE.
+
 2011-01-31  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/47463

diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 24e9ea5..424feb1 100644 (file)
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1605,6 +1605,15 @@ show_code_node (int level, gfc_code *c)
          show_expr (c->expr2);
        }
 
+      if (c->expr3)
+       {
+         if (c->expr3->mold)
+           fputs (" MOLD=", dumpfile);
+         else
+           fputs (" SOURCE=", dumpfile);
+         show_expr (c->expr3);
+       }
+
       for (a = c->ext.alloc.list; a; a = a->next)
        {
          fputc (' ', dumpfile);

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index ec9dd42..d8309d2 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -35,6 +35,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "intrinsic.h"
 #include "constructor.h"
+#include "arith.h"
 
 /* Given printf-like arguments, return a stable version of the result string. 
 
@@ -2044,11 +2045,31 @@ gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
 
 void
 gfc_resolve_repeat (gfc_expr *f, gfc_expr *string,
-                   gfc_expr *ncopies ATTRIBUTE_UNUSED)
+                   gfc_expr *ncopies)
 {
+  int len;
+  gfc_expr *tmp;
   f->ts.type = BT_CHARACTER;
   f->ts.kind = string->ts.kind;
   f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind);
+
+  /* If possible, generate a character length.  */
+  if (f->ts.u.cl == NULL)
+    f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+  tmp = NULL;
+  if (string->expr_type == EXPR_CONSTANT)
+    {
+      len = string->value.character.length;
+      tmp = gfc_get_int_expr (gfc_default_integer_kind, NULL , len);
+    }
+  else if (string->ts.u.cl && string->ts.u.cl->length)
+    {
+      tmp = gfc_copy_expr (string->ts.u.cl->length);
+    }
+
+  if (tmp)
+    f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies));
 }
 
 

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 161b309..2ac6989 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4522,15 +4522,30 @@ gfc_trans_allocate (gfc_code * code)
                      gfc_conv_expr (&se_sz, code->expr3);
                      memsz = se_sz.string_length;
                    }
-                 else
+                 else if (code->expr3->ts.u.cl
+                            && code->expr3->ts.u.cl->length)
+                   {
+                     gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
+                     gfc_add_block_to_block (&se.pre, &se_sz.pre);
+                     se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+                     gfc_add_block_to_block (&se.pre, &se_sz.post);
+                     memsz = se_sz.expr;
+                   }
+                 else if (code->ext.alloc.ts.u.cl
+                            && code->ext.alloc.ts.u.cl->length)
                    {
                      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
                      memsz = se_sz.expr;
                    }
-                 if (TREE_CODE (se.string_length) == VAR_DECL)
-                    gfc_add_modify (&block, se.string_length,
-                                   fold_convert (TREE_TYPE (se.string_length),
-                                                 memsz));
+                 else
+                   {
+                     /* This is likely to be inefficient.  */
+                     gfc_conv_expr (&se_sz, code->expr3);
+                     gfc_add_block_to_block (&se.pre, &se_sz.pre);
+                     se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+                     gfc_add_block_to_block (&se.pre, &se_sz.post);
+                     memsz = se_sz.string_length;
+                   }
                }
              else
                /* Otherwise use the stored string length.  */
@@ -4539,7 +4554,7 @@ gfc_trans_allocate (gfc_code * code)
 
              /* Store the string length.  */
              if (tmp && TREE_CODE (tmp) == VAR_DECL)
-               gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp),
+               gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
                                memsz));
 
              /* Convert to size in bytes, using the character KIND.  */
@@ -4556,18 +4571,8 @@ gfc_trans_allocate (gfc_code * code)
 
          if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
            {
-             if (expr->ts.deferred)
-               {
-                 gfc_se se_sz;
-                 gfc_init_se (&se_sz, NULL);
-                 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
-                 memsz = se_sz.expr;
-                  gfc_add_modify (&block, se.string_length,
-                                 fold_convert (TREE_TYPE (se.string_length),
-                                               memsz));
-               }
-             else
-               memsz = se.string_length;
+             memsz = se.string_length;
+
              /* Convert to size in bytes, using the character KIND.  */
              tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
              tmp = TYPE_SIZE_UNIT (tmp);
@@ -4664,8 +4669,15 @@ gfc_trans_allocate (gfc_code * code)
              tmp = gfc_finish_block (&call.pre);
            }
          else
-           tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
-                                       rhs, false, false);
+           {
+             /* Switch off automatic reallocation since we have just done
+                the ALLOCATE.  */
+             int realloc_lhs = gfc_option.flag_realloc_lhs;
+             gfc_option.flag_realloc_lhs = 0;
+             tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+                                         rhs, false, false);
+             gfc_option.flag_realloc_lhs = realloc_lhs;
+           }
          gfc_free_expr (rhs);
          gfc_add_expr_to_block (&block, tmp);
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0c17d83..824f3ca 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-01-31  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/47519
+       * gfortran.dg/allocate_deferred_char_scalar_2.f03: New test.
+
 2011-01-31  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/47463

diff --git a/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03 b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03
new file mode 100644 (file)
index 0000000..1f0f433
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_2.f03
@@ -0,0 +1,21 @@
+! { dg-do run }
+! Test the fix for PR47519, in which the character length was not
+! calculated for the SOURCE expressions below and an ICE resulted. 
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+program note7_35
+   implicit none
+   character(:), allocatable :: name
+   character(:), allocatable :: src
+   integer n
+   n = 10
+   allocate(name, SOURCE=repeat('x',n))
+   if (name .ne. 'xxxxxxxxxx') call abort
+   if (len (name) .ne. 10 ) call abort
+   deallocate(name)
+   src = 'xyxy'
+   allocate(name, SOURCE=repeat(src,n))
+   if (name(37:40) .ne. 'xyxy') call abort
+   if (len (name) .ne. 40 ) call abort
+end program note7_35