Re: [Patch, fortran] PR29422 and PR29428 - allocatable component wrinkles

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

Oops - I forgot the testcases.  Please fuind attached the complete patch.

Paul

> 2006-10-12 Paul Thomas <pault@gcc.gnu.org>
>
> 	PR fortran/29422
> 	* resolve.c (resolve_transfer): Test functions for suitability
> 	for IO, as well as variables.
>
> 	PR fortran/29428
> 	* trans-expr.c (gfc_trans_scalar_assign): Remove nullify of
> 	rhs expression.
>
> 2006-10-12 Paul Thomas <pault@gcc.gnu.org>
>
> 	PR fortran/29422
> 	* gfortran.dg/alloc_comp_constraint_4.f90: New test.
>
> 	PR fortran/29428
> 	* gfortran.dg/alloc_comp_assign_5.f90: New test.
>  

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 117628)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_scalar_assign (gfc_se * lse, g
*** 3261,3279 ****
  			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
  
        /* Do a deep copy if the rhs is a variable, if it is not the
! 	 same as the lhs.  Otherwise, nullify the data fields so that the
! 	 lhs retains the allocated resources.  */
        if (r_is_var)
  	{
  	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
  	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
  	  gfc_add_expr_to_block (&block, tmp);
  	}
-       else
- 	{
- 	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
- 	  gfc_add_expr_to_block (&block, tmp);
- 	}
      }
    else
      {
--- 3261,3273 ----
  			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
  
        /* Do a deep copy if the rhs is a variable, if it is not the
! 	 same as the lhs.  */
        if (r_is_var)
  	{
  	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
  	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
  	  gfc_add_expr_to_block (&block, tmp);
  	}
      }
    else
      {
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 117628)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_transfer (gfc_code * code)
*** 4167,4173 ****
  
    exp = code->expr;
  
!   if (exp->expr_type != EXPR_VARIABLE)
      return;
  
    sym = exp->symtree->n.sym;
--- 4167,4174 ----
  
    exp = code->expr;
  
!   if (exp->expr_type != EXPR_VARIABLE
! 	&& exp->expr_type != EXPR_FUNCTION)
      return;
  
    sym = exp->symtree->n.sym;
Index: gcc/testsuite/gfortran.dg/alloc_comp_constraint_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constraint_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constraint_4.f90	(revision 0)
***************
*** 0 ****
--- 1,20 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR29422, in which function results
+ ! were not tested for suitability in IO statements.
+ !
+ ! Contributed by Dominique d'Humieres  <dominiq@lps.ens.fr>
+ !
+ Type drv
+  Integer :: i
+  Integer, allocatable :: arr(:)
+ End type drv
+ 
+   print *, fun1 () ! { dg-error "cannot have ALLOCATABLE" }
+ 
+ contains
+   Function fun1 ()
+ 
+     Type(drv) :: fun1
+     fun1%i = 10
+   end function fun1
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_5.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_5.f90	(revision 0)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do run }
+ ! { dg-options "-O2" }
+ ! Tests the fix for PR29428, in which the assignment of
+ ! a function result would result in the function being
+ ! called twice, if it were not a result by reference,
+ ! because of a spurious nullify in gfc_trans_scalar_assign.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+ program test
+ implicit none
+ 
+   type A
+     integer, allocatable :: j(:)
+   end type A
+ 
+   type(A):: x
+   integer :: ctr = 0
+ 
+   x = f()
+ 
+   if (ctr /= 1) call abort ()
+ 
+ contains
+ 
+   function f()
+     type(A):: f
+       ctr = ctr + 1
+       f = A ((/1,2/))
+   end function f
+ 
+ end program