[fortran,pr66578,v1,F2008] Invalid free on allocate(...,source=a(:)) in block

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 223641)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5877,5882 ****
--- 5877,5896 ----
    fntype = TREE_TYPE (TREE_TYPE (se->expr));
    se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
  
+   /* Allocatable scalar function results must be freed and nullified
+      after use. This necessitates the creation of a temporary to
+      hold the result to prevent duplicate calls.  */
+   if (!byref && sym->ts.type != BT_CHARACTER
+       && sym->attr.allocatable && !sym->attr.dimension)
+     {
+       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+       gfc_add_modify (&se->pre, tmp, se->expr);
+       se->expr = tmp;
+       tmp = gfc_call_free (tmp);
+       gfc_add_expr_to_block (&post, tmp);
+       gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
+     }
+ 
    /* If we have a pointer function, but we don't want a pointer, e.g.
       something like
          x = f()
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 223641)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 5214,5219 ****
--- 5214,5220 ----
  				     false, false);
  	  gfc_add_block_to_block (&block, &se.pre);
  	  gfc_add_block_to_block (&post, &se.post);
+ 
  	  /* Prevent aliasing, i.e., se.expr may be already a
  		 variable declaration.  */
  	  if (!VAR_P (se.expr))
*************** gfc_trans_allocate (gfc_code * code)
*** 5223,5230 ****
  						 se.expr);
  	      /* We need a regular (non-UID) symbol here, therefore give a
  		 prefix.  */
! 	      var = gfc_create_var (TREE_TYPE (tmp), "atmp");
  	      gfc_add_modify_loc (input_location, &block, var, tmp);
  	      tmp = var;
  	    }
  	  else
--- 5224,5243 ----
  						 se.expr);
  	      /* We need a regular (non-UID) symbol here, therefore give a
  		 prefix.  */
! 	      var = gfc_create_var (TREE_TYPE (tmp), "expr3");
  	      gfc_add_modify_loc (input_location, &block, var, tmp);
+ 
+ 	      /* Deallocate any allocatable components after all the allocations
+ 		 and assignments of expr3 have been completed.  */
+ 	      if (code->expr3->ts.type == BT_DERIVED
+ 		  && code->expr3->rank == 0
+ 		  && code->expr3->ts.u.derived->attr.alloc_comp)
+ 		{
+ 		  tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+ 						   var, 0);
+ 		  gfc_add_expr_to_block (&post, tmp);
+ 		}
+ 
  	      tmp = var;
  	    }
  	  else
Index: gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90	(working copy)
***************
*** 0 ****
--- 1,70 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR66079. The original problem was with the first
+ ! allocate statement. The rest of this testcase fixes problems found
+ ! whilst working on it!
+ !
+ ! Reported by Damian Rouson  <damian@sourceryinstitute.org>
+ !
+   type subdata
+     integer, allocatable :: b
+   endtype
+ !  block
+     call newRealVec
+ !  end block
+ contains
+   subroutine newRealVec
+     type(subdata), allocatable :: d, e, f
+     character(:), allocatable :: g, h, i
+     character(8), allocatable :: j
+     allocate(d,source=subdata(1)) ! memory was lost, now OK
+     allocate(e,source=d) ! OK
+     allocate(f,source=create (99)) ! memory was lost, now OK
+     if (d%b .ne. 1) call abort
+     if (e%b .ne. 1) call abort
+     if (f%b .ne. 99) call abort
+     allocate (g, source = greeting1("good day"))
+     if (g .ne. "good day") call abort
+     allocate (h, source = greeting2("hello"))
+     if (h .ne. "hello") call abort
+     allocate (i, source = greeting3("hiya!"))
+     if (i .ne. "hiya!") call abort
+     call greeting4 (j, "Goodbye ") ! Test that dummy arguments are OK
+     if (j .ne. "Goodbye ") call abort
+   end subroutine
+ 
+   function create (arg) result(res)
+     integer :: arg
+     type(subdata), allocatable :: res, res1
+     allocate(res, res1, source = subdata(arg))
+   end function
+ 
+   function greeting1 (arg) result(res) ! memory was lost, now OK
+     character(*) :: arg
+     Character(:), allocatable :: res
+     allocate(res, source = arg)
+   end function
+ 
+   function greeting2 (arg) result(res)
+     character(5) :: arg
+     Character(:), allocatable :: res
+     allocate(res, source = arg)
+   end function
+ 
+   function greeting3 (arg) result(res)
+     character(5) :: arg
+     Character(5), allocatable :: res, res1
+     allocate(res, res1, source = arg) ! Caused an ICE
+     if (res1 .ne. res) call abort
+   end function
+ 
+   subroutine greeting4 (res, arg)
+     character(8), intent(in) :: arg
+     Character(8), allocatable, intent(out) :: res
+     allocate(res, source = arg) ! Caused an ICE
+   end subroutine
+ end
+ ! { dg-final { scan-tree-dump-times "builtin_malloc" 20 "original" } }
+ ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }