re PR fortran/47592 (Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x',bar())))

2011-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47592
	* trans-stmt.c (gfc_trans_allocate): For deferred character
	length allocations with SOURCE, store to the values and string
	length to avoid calculating twice.  Replace gfc_start_block
	with gfc_init_block to avoid unnecessary contexts and to keep
	declarations of temporaries where they should be. Tidy up the
	code a bit.

2011-02-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47592
	* gfortran.dg/allocate_with_source_1 : New test.

From-SVN: r169862

gcc/fortran/ChangeLog

+2011-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47592
+	* trans-stmt.c (gfc_trans_allocate): For deferred character
+	length allocations with SOURCE, store to the values and string
+	length to avoid calculating twice.  Replace gfc_start_block
+	with gfc_init_block to avoid unnecessary contexts and to keep
+	declarations of temporaries where they should be. Tidy up the
+	code a bit.
+
 2011-02-05  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR fortran/42434

gcc/fortran/trans-stmt.c

@@ -4451,14 +4451,20 @@ gfc_trans_allocate (gfc_code * code)
   tree pstat;
   tree error_label;
   tree memsz;
+  tree expr3;
+  tree slen3;
   stmtblock_t block;
+  stmtblock_t post;
+  gfc_expr *sz;
+  gfc_se se_sz;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
   pstat = stat = error_label = tmp = memsz = NULL_TREE;
 
-  gfc_start_block (&block);
+  gfc_init_block (&block);
+  gfc_init_block (&post);
 
   /* Either STAT= and/or ERRMSG is present.  */
   if (code->expr1 || code->expr2)
@@ -4472,6 +4478,9 @@ gfc_trans_allocate (gfc_code * code)
       TREE_USED (error_label) = 1;
     }
 
+  expr3 = NULL_TREE;
+  slen3 = NULL_TREE;
+
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
       expr = gfc_copy_expr (al->expr);
@@ -4480,7 +4489,6 @@ gfc_trans_allocate (gfc_code * code)
 	gfc_add_data_component (expr);
 
       gfc_init_se (&se, NULL);
-      gfc_start_block (&se.pre);
 
       se.want_pointer = 1;
       se.descriptor_only = 1;
@@ -4495,8 +4503,6 @@ gfc_trans_allocate (gfc_code * code)
 	    {
 	      if (code->expr3->ts.type == BT_CLASS)
 		{
-		  gfc_expr *sz;
-		  gfc_se se_sz;
 		  sz = gfc_copy_expr (code->expr3);
 		  gfc_add_vptr_component (sz);
 		  gfc_add_size_component (sz);
@@ -4514,7 +4520,6 @@ gfc_trans_allocate (gfc_code * code)
 	      if (!code->expr3->ts.u.cl->backend_decl)
 		{
 		  /* Convert and use the length expression.  */
-		  gfc_se se_sz;
 		  gfc_init_se (&se_sz, NULL);
 		  if (code->expr3->expr_type == EXPR_VARIABLE
 			|| code->expr3->expr_type == EXPR_CONSTANT)
@@ -4522,7 +4527,8 @@ gfc_trans_allocate (gfc_code * code)
 		      gfc_conv_expr (&se_sz, code->expr3);
 		      memsz = se_sz.string_length;
 		    }
-		  else if (code->expr3->ts.u.cl
+		  else if (code->expr3->mold
+			     && code->expr3->ts.u.cl
 			     && code->expr3->ts.u.cl->length)
 		    {
 		      gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
@@ -4531,20 +4537,21 @@ gfc_trans_allocate (gfc_code * code)
 		      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;
-		    }
 		  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;
+		      /* This is would be inefficient and possibly could
+			 generate wrong code if the result were not stored
+			 in expr3/slen3.  */
+		      if (slen3 == NULL_TREE)
+			{
+			  gfc_conv_expr (&se_sz, code->expr3);
+			  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+			  expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
+			  gfc_add_block_to_block (&post, &se_sz.post);
+			  slen3 = gfc_evaluate_now (se_sz.string_length,
+						    &se.pre);
+			}
+		      memsz = slen3;
 		    }
 		}
 	      else
@@ -4580,31 +4587,13 @@ gfc_trans_allocate (gfc_code * code)
 				       TREE_TYPE (tmp), tmp,
 				       fold_convert (TREE_TYPE (tmp), memsz));
 	    }
+
 	  /* Allocate - for non-pointers with re-alloc checking.  */
-	  {
-	    gfc_ref *ref;
-	    bool allocatable;
-
-	    ref = expr->ref;
-
-	    /* Find the last reference in the chain.  */
-	    while (ref && ref->next != NULL)
-	      {
-	        gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
-	        ref = ref->next;
-	      }
-
-	    if (!ref)
-	      allocatable = expr->symtree->n.sym->attr.allocatable;
-	    else
-	      allocatable = ref->u.c.component->attr.allocatable;
-
-	    if (allocatable)
-	      tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
-						    pstat, expr);
-	    else
-	      tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
-	  }
+	  if (gfc_expr_attr (expr).allocatable)
+	    tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
+						  pstat, expr);
+	  else
+	    tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
 
 	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
 				 se.expr,
@@ -4629,11 +4618,9 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
-
 	}
 
-      tmp = gfc_finish_block (&se.pre);
-      gfc_add_expr_to_block (&block, tmp);
+      gfc_add_block_to_block (&block, &se.pre);
 
       if (code->expr3 && !code->expr3->mold)
 	{
@@ -4668,6 +4655,13 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_add_block_to_block (&call.pre, &call.post);
 	      tmp = gfc_finish_block (&call.pre);
 	    }
+	  else if (expr3 != NULL_TREE)
+	    {
+	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+	      gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
+				     slen3, expr3, code->expr3->ts.kind);
+	      tmp = NULL_TREE;
+	    }
 	  else
 	    {
 	      /* Switch off automatic reallocation since we have just done
@@ -4799,6 +4793,9 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_block_to_block (&block, &post);
+
   return gfc_finish_block (&block);
 }
 

gcc/testsuite/ChangeLog

+2011-02-06  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/47592
+	* gfortran.dg/allocate_with_source_1 : New test.
+
 2011-02-05  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/47610

gcc/testsuite/gfortran.dg/allocate_with_source_1.f90

+! { dg-do run }
+! Test the fix for PR47592, in which the SOURCE expression was
+! being called twice.
+!
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+!
+module foo
+  implicit none
+contains
+  function bar()
+    integer bar
+    integer :: i=9
+    i = i + 1
+    bar = i
+  end function bar
+end module foo
+
+program note7_35
+  use foo
+  implicit none
+  character(:), allocatable :: name
+  character(:), allocatable :: src
+  integer n
+  n = 10
+  allocate(name, SOURCE=repeat('x',bar()))
+  if (name .ne. 'xxxxxxxxxx') call abort
+  if (len (name) .ne. 10 ) call abort
+end program note7_35
+! { dg-final { cleanup-modules "foo" } }