re PR fortran/47519 (Deferred-length string wrong results with character intrinsic functions)

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.

From-SVN: r169444

4 files changed, 73 insertions, 21 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e146d76..ae08fdc 100644
--- 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
--- 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
--- 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
--- 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);
 	}