re PR fortran/34820 (internal compiler error: in gfc_conv_descriptor_data_get,…

re PR fortran/34820 (internal compiler error: in gfc_conv_descriptor_data_get, at fortran/trans-array.c:147)

2008-11-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34820
	* trans-expr.c (gfc_conv_function_call): Remove all code to
	deallocate intent out derived types with allocatable
	components.
	(gfc_trans_assignment_1): An assignment from a scalar to an
	array of derived types with allocatable components, requires
	a deep copy to each array element and deallocation of the
	converted rhs expression afterwards.
	* trans-array.c : Minor whitespace.
	* trans-decl.c (init_intent_out_dt): Add code to deallocate
	allocatable components of derived types with intent out.
	(generate_local_decl): If these types are unused, set them
	referenced anyway but allow the uninitialized warning.

	PR fortran/34143
	* trans-expr.c (gfc_trans_subcomponent_assign): If a conversion
	expression has a null data pointer argument, nullify the
	allocatable component.

	PR fortran/32795
	* trans-expr.c (gfc_trans_subcomponent_assign): Only nullify
	the data pointer if the source is not a variable.

2008-11-24  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34820
	* gfortran.dg/alloc_comp_constructor_6.f90 : New test.
	* gfortran.dg/alloc_comp_basics_1.f90 : Reduce expected refs to
	'builtin_free' from 24 to 18.

	PR fortran/34143
	* gfortran.dg/alloc_comp_constructor_5.f90 : New test.

	PR fortran/32795
	* gfortran.dg/alloc_comp_constructor_4.f90 : New test.

From-SVN: r142148

gcc/fortran/ChangeLog

+2008-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34820
+	* trans-expr.c (gfc_conv_function_call): Remove all code to
+	deallocate intent out derived types with allocatable
+	components.
+	(gfc_trans_assignment_1): An assignment from a scalar to an
+	array of derived types with allocatable components, requires
+	a deep copy to each array element and deallocation of the
+	converted rhs expression afterwards.
+	* trans-array.c : Minor whitespace.
+	* trans-decl.c (init_intent_out_dt): Add code to deallocate
+	allocatable components of derived types with intent out.
+	(generate_local_decl): If these types are unused, set them
+	referenced anyway but allow the uninitialized warning.
+
+	PR fortran/34143
+	* trans-expr.c (gfc_trans_subcomponent_assign): If a conversion
+	expression has a null data pointer argument, nullify the
+	allocatable component.
+
+	PR fortran/32795
+	* trans-expr.c (gfc_trans_subcomponent_assign): Only nullify
+	the data pointer if the source is not a variable.
+
 2008-11-23  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/37735

gcc/fortran/trans-array.c

@@ -5276,7 +5276,6 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
       gfc_conv_expr_descriptor (se, expr, ss);
     }
 
-
   /* Deallocate the allocatable components of structures that are
      not variable.  */
   if (expr->ts.type == BT_DERIVED

gcc/fortran/trans-decl.c

@@ -2781,20 +2781,34 @@ gfc_init_default_dt (gfc_symbol * sym, tree body)
 }
 
 
-/* Initialize INTENT(OUT) derived type dummies.  */
+/* Initialize INTENT(OUT) derived type dummies.  As well as giving
+   them their default initializer, if they do not have allocatable
+   components, they have their allocatable components deallocated. */
+
 static tree
 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
 {
   stmtblock_t fnblock;
   gfc_formal_arglist *f;
+  tree tmp;
 
   gfc_init_block (&fnblock);
   for (f = proc_sym->formal; f; f = f->next)
     if (f->sym && f->sym->attr.intent == INTENT_OUT
-	  && f->sym->ts.type == BT_DERIVED
-	  && !f->sym->ts.derived->attr.alloc_comp
-	  && f->sym->value)
-      body = gfc_init_default_dt (f->sym, body);
+	  && f->sym->ts.type == BT_DERIVED)
+      {
+	if (f->sym->ts.derived->attr.alloc_comp)
+	  {
+	    tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
+					     f->sym->backend_decl,
+					     f->sym->as ? f->sym->as->rank : 0);
+	    gfc_add_expr_to_block (&fnblock, tmp);
+	  }
+
+	if (!f->sym->ts.derived->attr.alloc_comp
+	      && f->sym->value)
+	  body = gfc_init_default_dt (f->sym, body);
+      }
 
   gfc_add_expr_to_block (&fnblock, body);
   return gfc_finish_block (&fnblock);
@@ -3482,10 +3496,10 @@ generate_local_decl (gfc_symbol * sym)
   if (sym->attr.flavor == FL_VARIABLE)
     {
       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
-        generate_dependency_declarations (sym);
+	generate_dependency_declarations (sym);
 
       if (sym->attr.referenced)
-        gfc_get_symbol_decl (sym);
+	gfc_get_symbol_decl (sym);
       /* INTENT(out) dummy arguments are likely meant to be set.  */
       else if (warn_unused_variable
 	       && sym->attr.dummy
@@ -3502,20 +3516,34 @@ generate_local_decl (gfc_symbol * sym)
 	       && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
 	gfc_warning ("Unused variable '%s' declared at %L", sym->name,
 		     &sym->declared_at);
+
       /* For variable length CHARACTER parameters, the PARM_DECL already
 	 references the length variable, so force gfc_get_symbol_decl
 	 even when not referenced.  If optimize > 0, it will be optimized
 	 away anyway.  But do this only after emitting -Wunused-parameter
 	 warning if requested.  */
-      if (sym->attr.dummy && ! sym->attr.referenced
-	  && sym->ts.type == BT_CHARACTER
-	  && sym->ts.cl->backend_decl != NULL
-	  && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+      if (sym->attr.dummy && !sym->attr.referenced
+	    && sym->ts.type == BT_CHARACTER
+	    && sym->ts.cl->backend_decl != NULL
+	    && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
 	{
 	  sym->attr.referenced = 1;
 	  gfc_get_symbol_decl (sym);
 	}
 
+      /* INTENT(out) dummy arguments with allocatable components are reset
+	 by default and need to be set referenced to generate the code for
+	 automatic lengths.  */
+      if (sym->attr.dummy && !sym->attr.referenced
+	    && sym->ts.type == BT_DERIVED
+	    && sym->ts.derived->attr.alloc_comp
+	    && sym->attr.intent == INTENT_OUT)
+	{
+	  sym->attr.referenced = 1;
+	  gfc_get_symbol_decl (sym);
+	}
+
+
       /* Check for dependencies in the array specification and string
 	length, adding the necessary declarations to the function.  We
 	mark the symbol now, as well as in traverse_ns, to prevent

gcc/fortran/trans-expr.c

@@ -2742,14 +2742,11 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       gfc_add_block_to_block (&post, &parmse.post);
 
       /* Allocated allocatable components of derived types must be
-	 deallocated for INTENT(OUT) dummy arguments and non-variable
-         scalars.  Non-variable arrays are dealt with in trans-array.c
-         (gfc_conv_array_parameter).  */
+	 deallocated for non-variable scalars.  Non-variable arrays are
+	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
       if (e && e->ts.type == BT_DERIVED
 	    && e->ts.derived->attr.alloc_comp
-	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
-		   ||
-		(e->expr_type != EXPR_VARIABLE && !e->rank)))
+	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
         {
 	  int parm_rank;
 	  tmp = build_fold_indirect_ref (parmse.expr);
@@ -2764,24 +2761,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    case (SCALAR_POINTER):
               tmp = build_fold_indirect_ref (tmp);
 	      break;
-	    case (ARRAY):
-              tmp = parmse.expr;
-	      break;
 	    }
 
-          tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
-	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
-	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
-			    tmp, build_empty_stmt ());
-
-	  if (e->expr_type != EXPR_VARIABLE)
-	    /* Don't deallocate non-variables until they have been used.  */
-	    gfc_add_expr_to_block (&se->post, tmp);
-	  else 
-	    {
-	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
-	      gfc_add_expr_to_block (&se->pre, tmp);
-	    }
+	  tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+	  gfc_add_expr_to_block (&se->post, tmp);
         }
 
       /* Character strings are passed as two parameters, a length and a
@@ -3610,9 +3593,10 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 					     cm->as->rank);
 
 	  gfc_add_expr_to_block (&block, tmp);
-
 	  gfc_add_block_to_block (&block, &se.post);
-	  gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
+
+	  if (expr->expr_type != EXPR_VARIABLE)
+	    gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
 
 	  /* Shift the lbound and ubound of temporaries to being unity, rather
 	     than zero, based.  Calculate the offset for all cases.  */
@@ -3644,6 +3628,35 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
 	      gfc_add_modify (&block, offset, tmp);
 	    }
+
+	  if (expr->expr_type == EXPR_FUNCTION
+		&& expr->value.function.isym
+		&& expr->value.function.isym->conversion
+		&& expr->value.function.actual->expr
+		&& expr->value.function.actual->expr->expr_type
+						== EXPR_VARIABLE)
+	    {
+	      /* If a conversion expression has a null data pointer
+		 argument, nullify the allocatable component.  */
+	      gfc_symbol *s;
+	      tree non_null_expr;
+	      tree null_expr;
+	      s = expr->value.function.actual->expr->symtree->n.sym;
+	      if (s->attr.allocatable || s->attr.pointer)
+		{
+		  non_null_expr = gfc_finish_block (&block);
+		  gfc_start_block (&block);
+		  gfc_conv_descriptor_data_set (&block, dest,
+						null_pointer_node);
+		  null_expr = gfc_finish_block (&block);
+		  tmp = gfc_conv_descriptor_data_get (s->backend_decl);
+		  tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
+			        fold_convert (TREE_TYPE (tmp),
+					      null_pointer_node));
+		  return build3_v (COND_EXPR, tmp, null_expr,
+				   non_null_expr);
+		}
+	    }
 	}
       else
 	{
@@ -4533,6 +4546,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
   stmtblock_t block;
   stmtblock_t body;
   bool l_is_temp;
+  bool scalar_to_array;
 
   /* Assignment of the form lhs = rhs.  */
   gfc_start_block (&block);
@@ -4616,9 +4630,24 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
   else
     gfc_conv_expr (&lse, expr1);
 
+  /* Assignments of scalar derived types with allocatable components
+     to arrays must be done with a deep copy and the rhs temporary
+     must have its components deallocated afterwards.  */
+  scalar_to_array = (expr2->ts.type == BT_DERIVED
+		       && expr2->ts.derived->attr.alloc_comp
+		       && expr2->expr_type != EXPR_VARIABLE
+		       && !gfc_is_constant_expr (expr2)
+		       && expr1->rank && !expr2->rank);
+  if (scalar_to_array)
+    {
+      tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+      gfc_add_expr_to_block (&loop.post, tmp);
+    }
+
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
 				 l_is_temp || init_flag,
-				 expr2->expr_type == EXPR_VARIABLE);
+				 (expr2->expr_type == EXPR_VARIABLE)
+				    || scalar_to_array);
   gfc_add_expr_to_block (&body, tmp);
 
   if (lss == gfc_ss_terminator)

gcc/testsuite/ChangeLog

+2008-11-24  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34820
+	* gfortran.dg/alloc_comp_constructor_6.f90 : New test.
+	* gfortran.dg/alloc_comp_basics_1.f90 : Reduce expected refs to
+	'builtin_free' from 24 to 18.
+
+	PR fortran/34143
+	* gfortran.dg/alloc_comp_constructor_5.f90 : New test.
+
+	PR fortran/32795
+	* gfortran.dg/alloc_comp_constructor_4.f90 : New test.
+
 2008-11-23  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/37735

gcc/testsuite/gfortran.dg/alloc_comp_auto_array_2.f90

+! { dg-do run }
+! Tests the fix for PR34820, in which the nullification of the
+! automatic array iregion occurred in the caller, rather than the
+! callee.  Since 'nproc' was not available, an ICE ensued. During
+! the bug fix, it was found that the scalar to array assignment
+! of derived types with allocatable components did not work and
+! the fix of this is tested too.
+!
+! Contributed by Toon Moene <toon@moene.indiv.nluug.nl>
+!
+module grid_io
+  type grid_index_region
+    integer, allocatable::lons(:)
+  end type grid_index_region
+contains
+  subroutine read_grid_header()
+    integer :: npiece = 1
+    type(grid_index_region),allocatable :: iregion(:)
+    allocate (iregion(npiece + 1))
+    call read_iregion(npiece,iregion)
+    if (size(iregion) .ne. npiece + 1) call abort
+    if (.not.allocated (iregion(npiece)%lons)) call abort
+    if (allocated (iregion(npiece+1)%lons)) call abort
+    if (any (iregion(npiece)%lons .ne. [(i, i = 1, npiece)])) call abort
+    deallocate (iregion)
+  end subroutine read_grid_header
+
+  subroutine read_iregion (nproc,iregion)
+    integer,intent(in)::nproc
+    type(grid_index_region), intent(OUT)::iregion(1:nproc)
+    integer :: iarg(nproc)
+    iarg = [(i, i = 1, nproc)]
+    iregion = grid_index_region (iarg) !
+  end subroutine read_iregion
+end module grid_io
+
+  use grid_io
+  call read_grid_header
+end
+! { dg-final { cleanup-tree-dump "grid_io" } }

gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90

@@ -139,6 +139,6 @@ contains
     end subroutine check_alloc2
 
 end program alloc
-! { dg-final { scan-tree-dump-times "builtin_free" 27 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 ! { dg-final { cleanup-modules "alloc_m" } }

gcc/testsuite/gfortran.dg/alloc_comp_constructor_4.f90

+! { dg-do run }
+! Tests the fix for PR32795, which was primarily about memory leakage is
+! certain combinations of alloctable components and constructors. This test
+! which appears in comment #2 of the PR has the advantage of a wrong
+! numeric result which is symptomatic.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+  type :: a
+    integer, allocatable :: i(:)
+  end type a
+  type(a) :: x, y
+  x = a ([1, 2, 3])
+  y = a (x%i(:))  ! used to cause a memory leak and wrong result
+  if (any (x%i .ne. [1, 2, 3])) call abort
+end

gcc/testsuite/gfortran.dg/alloc_comp_constructor_5.f90

+! { dg-do run }
+! { dg-options "-fdefault-integer-8" }
+! Tests the fix for PR34143, in which the implicit conversion of yy, with
+! fdefault-integer-8, would cause a segfault at runtime.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+Program test_constructor
+    implicit none
+    type :: thytype
+        integer(4) :: a(2,2)
+    end type thytype
+    type :: mytype
+        integer(4), allocatable :: a(:, :)
+        type(thytype), allocatable :: q(:)
+    end type mytype
+    integer, allocatable :: yy(:,:)
+    type (thytype), allocatable :: bar(:)
+    type (mytype) :: x, y
+    x = mytype(yy, bar)
+    if (allocated (x%a) .or. allocated (x%q)) call abort
+    allocate (yy(2,2))
+    allocate (bar(2))
+    yy = reshape ([10,20,30,40],[2,2])
+    bar = thytype (reshape ([1,2,3,4],[2,2]))
+    ! Check that unallocated allocatables work
+    y = mytype(yy, bar)
+    if (.not.allocated (y%a) .or. .not.allocated (y%q)) call abort
+end program test_constructor

gcc/testsuite/gfortran.dg/alloc_comp_constructor_6.f90

+! { dg-do run }
+! { dg-options "-fdefault-integer-8 -O2" }
+! Tests the fix for PR34143, where the implicit type
+! conversion in the derived type constructor would fail,
+! when 'yy' was not allocated.  The testscase is an
+! extract from alloc_comp_constructor.f90.
+!
+! Reported by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+Program test_constructor
+    implicit none
+    type :: thytype
+        integer(4) :: a(2,2)
+    end type thytype
+    type :: mytype
+        integer(4), allocatable :: a(:, :)
+        type(thytype), allocatable :: q(:)
+    end type mytype
+    integer, allocatable :: yy(:,:)
+    type (thytype), allocatable :: bar(:)
+    call non_alloc
+    call alloc
+contains
+    subroutine non_alloc
+      type (mytype) :: x
+      x = mytype(yy, bar)
+      if (allocated (x%a) .or. allocated (x%q)) call abort
+    end subroutine non_alloc
+    subroutine alloc
+      type (mytype) :: x
+      allocate (yy(2,2))
+      allocate (bar(2))
+      yy = reshape ([10,20,30,40],[2,2])
+      bar = thytype (reshape ([1,2,3,4],[2,2]))
+      x = mytype(yy, bar)
+      if (.not.allocated (x%a) .or. .not.allocated (x%q)) call abort
+    end subroutine alloc
+end program test_constructor