diff mbox

[fortran] PR47592 - Multiple function invocation with ALLOCATE (SOURCE=REPEAT('x',bar()))

Message ID AANLkTimq9af+mnhnX2Ois+_sC+ZL=WiUn=6rGAQwv+hB@mail.gmail.com
State New
Headers show

Commit Message

Paul Richard Thomas Feb. 6, 2011, 9:59 a.m. UTC 
The fix for this PR is sufficiently straightforward that the patch and
the ChangeLogs speak for themselves.

Note that I have removed the calls of gfc_start_block and replaced
them with gfc_init_block, since the former does all sorts of strange
things with declarations as the warning in trans.c indicates.

Bootstraps and regtests on FC9/x86_64 - OK for trunk?

Cheers

Paul

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.

Comments

Tobias Burnus Feb. 6, 2011, 11:24 a.m. UTC | #1 
Am 06.02.2011 10:59, Paul Richard Thomas wrote:
> Note that I have removed the calls of gfc_start_block and replaced
> them with gfc_init_block, since the former does all sorts of strange
> things with declarations as the warning in trans.c indicates.

I think there are several places in gfortran where an init_block would 
be better than a start_block.

> Bootstraps and regtests on FC9/x86_64 - OK for trunk?

OK, though you could consider shortening the code as indicated below. 
Thanks for the patch!

> +
> ! 	  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)
>

That's mostly unchanged from previous version, but couldn't one replace 
it by a simple "if (gfc_expr_attr (expr).allocatable)"? I think 
gfc_expr_attr does not always do the right thing (regarding when to 
ignore and not ignore array/substring refs), but I think here it does.

Tobias
Paul Richard Thomas Feb. 6, 2011, 12:17 p.m. UTC | #2 
Dear Tobias,

I thought that you were not doing gfortran this weekend :-)

> Note that I have removed the calls of gfc_start_block and replaced
> them with gfc_init_block, since the former does all sorts of strange
> things with declarations as the warning in trans.c indicates.
>
> I think there are several places in gfortran where an init_block would be
> better than a start_block.

Indeed - I have been burned more than once by using start, rather than init.

>
> Bootstraps and regtests on FC9/x86_64 - OK for trunk?
>
> OK, though you could consider shortening the code as indicated below. Thanks
> for the patch!
>
> +
> ! 	  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)
>
>
> That's mostly unchanged from previous version, but couldn't one replace it
> by a simple "if (gfc_expr_attr (expr).allocatable)"? I think gfc_expr_attr
> does not always do the right thing (regarding when to ignore and not ignore
> array/substring refs), but I think here it does.

I'll give it a try.  Thanks for the review.  Now to module backend_decls.....

Cheers

Paul
Paul Richard Thomas Feb. 6, 2011, 2:24 p.m. UTC | #3 
Dear All,

Sending        gcc/fortran/ChangeLog
Sending        gcc/fortran/trans-stmt.c
Sending        gcc/testsuite/ChangeLog
Adding         gcc/testsuite/gfortran.dg/allocate_with_source_1.f90
Transmitting file data ....
Committed revision 169862.

>> That's mostly unchanged from previous version, but couldn't one replace it
>> by a simple "if (gfc_expr_attr (expr).allocatable)"? I think gfc_expr_attr
>> does not always do the right thing (regarding when to ignore and not ignore
>> array/substring refs), but I think here it does.
>

With this suggestion - thanks.

Cheers

Paul
diff mbox

Patch

Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 169860)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4451,4464 ****
    tree pstat;
    tree error_label;
    tree memsz;
    stmtblock_t block;
  
    if (!code->ext.alloc.list)
      return NULL_TREE;
  
    pstat = stat = error_label = tmp = memsz = NULL_TREE;
  
!   gfc_start_block (&block);
  
    /* Either STAT= and/or ERRMSG is present.  */
    if (code->expr1 || code->expr2)
--- 4451,4472 ----
    tree pstat;
    tree error_label;
    tree memsz;
+   tree expr3;
+   tree slen3;
    stmtblock_t block;
+   stmtblock_t post;
+   gfc_expr *sz;
+   gfc_se se_sz;
+   gfc_ref *ref;
+   bool allocatable;
  
    if (!code->ext.alloc.list)
      return NULL_TREE;
  
    pstat = stat = error_label = tmp = memsz = NULL_TREE;
  
!   gfc_init_block (&block);
!   gfc_init_block (&post);
  
    /* Either STAT= and/or ERRMSG is present.  */
    if (code->expr1 || code->expr2)
*************** gfc_trans_allocate (gfc_code * code)
*** 4472,4477 ****
--- 4480,4488 ----
        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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4480,4486 ****
  	gfc_add_data_component (expr);
  
        gfc_init_se (&se, NULL);
-       gfc_start_block (&se.pre);
  
        se.want_pointer = 1;
        se.descriptor_only = 1;
--- 4491,4496 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4495,4502 ****
  	    {
  	      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);
--- 4505,4510 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4514,4520 ****
  	      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,4527 ----
*************** gfc_trans_allocate (gfc_code * code)
*** 4522,4528 ****
  		      gfc_conv_expr (&se_sz, code->expr3);
  		      memsz = se_sz.string_length;
  		    }
! 		  else if (code->expr3->ts.u.cl
  			     && code->expr3->ts.u.cl->length)
  		    {
  		      gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
--- 4529,4536 ----
  		      gfc_conv_expr (&se_sz, code->expr3);
  		      memsz = se_sz.string_length;
  		    }
! 		  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);
*************** gfc_trans_allocate (gfc_code * code)
*** 4531,4550 ****
  		      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;
  		    }
  		}
  	      else
--- 4539,4559 ----
  		      gfc_add_block_to_block (&se.pre, &se_sz.post);
  		      memsz = se_sz.expr;
  		    }
  		  else
  		    {
! 		      /* 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
*************** gfc_trans_allocate (gfc_code * code)
*** 4580,4610 ****
  				       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);
! 	  }
  
  	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
  				 se.expr,
--- 4589,4613 ----
  				       TREE_TYPE (tmp), tmp,
  				       fold_convert (TREE_TYPE (tmp), memsz));
  	    }
+ 
  	  /* Allocate - for non-pointers with re-alloc checking.  */
! 	  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);
  
  	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
  				 se.expr,
*************** gfc_trans_allocate (gfc_code * code)
*** 4629,4639 ****
  	      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);
  
        if (code->expr3 && !code->expr3->mold)
  	{
--- 4632,4640 ----
  	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
  	      gfc_add_expr_to_block (&se.pre, tmp);
  	    }
  	}
  
!       gfc_add_block_to_block (&block, &se.pre);
  
        if (code->expr3 && !code->expr3->mold)
  	{
*************** gfc_trans_allocate (gfc_code * code)
*** 4668,4673 ****
--- 4669,4681 ----
  	      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
*************** gfc_trans_allocate (gfc_code * code)
*** 4799,4804 ****
--- 4807,4815 ----
        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);
  }
  
Index: gcc/testsuite/gfortran.dg/allocate_with_source_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_with_source_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/allocate_with_source_1.f90	(revision 0)
***************
*** 0 ****
--- 1,29 ----
+ ! { 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" } }