re PR fortran/42647 ([F03] Missed initialization/dealloc of allocatable scalar…

re PR fortran/42647 ([F03] Missed initialization/dealloc of allocatable scalar DT with allocatable component)

2010-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42647
	* trans.h (gfc_deallocate_scalar_with_status): New prototype.
	* trans.c (gfc_deallocate_scalar_with_status): New function for
	deallocation of allocatable scalars.
	* trans-array.c (structure_alloc_comps): Call it here ...
	* trans-decl.c (gfc_trans_deferred_vars): ... here ...
	* trans-stmt.c (gfc_trans_deallocate): ... and here.

2010-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42647
	* gfortran.dg/allocatable_scalar_9.f90: Extended.
	* gfortran.dg/allocatable_scalar_10.f90: New.
	* gfortran.dg/class_19.f03: Extended.

From-SVN: r165973

gcc/fortran/ChangeLog

+2010-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42647
+	* trans.h (gfc_deallocate_scalar_with_status): New prototype.
+	* trans.c (gfc_deallocate_scalar_with_status): New function for
+	deallocation of allocatable scalars.
+	* trans-array.c (structure_alloc_comps): Call it here ...
+	* trans-decl.c (gfc_trans_deferred_vars): ... here ...
+	* trans-stmt.c (gfc_trans_deallocate): ... and here.
+
 2010-10-26  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/45451

gcc/fortran/trans-array.c

@@ -6281,22 +6281,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
       switch (purpose)
 	{
 	case DEALLOCATE_ALLOC_COMP:
-	  /* Do not deallocate the components of ultimate pointer
-	     components.  */
-	  if (cmp_has_alloc_comps && !c->attr.pointer)
+	  if (c->attr.allocatable && c->attr.dimension)
 	    {
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      rank = c->as ? c->as->rank : 0;
+	      if (cmp_has_alloc_comps && !c->attr.pointer)
+		{
+		  /* Do not deallocate the components of ultimate pointer
+		     components.  */
 		  tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-					   rank, purpose);
+					       c->as->rank, purpose);
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
-
-	  if (c->attr.allocatable && c->attr.dimension)
-	    {
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
 	      tmp = gfc_trans_dealloc_allocated (comp);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
@@ -6306,7 +6302,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
 
-	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+						       c->ts);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 
 	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@@ -6325,7 +6322,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
 
-	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+						       CLASS_DATA (c)->ts);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 
 	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,

gcc/fortran/trans-decl.c

@@ -3408,10 +3408,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
-	      tmp = NULL;
 	      if (!sym->attr.result)
-		tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
-						  true, NULL);
+		tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
+							 NULL, sym->ts);
+	      else
+		tmp = NULL;
 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 	    }
 	}

gcc/fortran/trans-stmt.c

@@ -4676,6 +4676,8 @@ gfc_trans_deallocate (gfc_code *code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
+      if (expr->rank)
+	{
 	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
 	    {
 	      gfc_ref *ref;
@@ -4694,12 +4696,12 @@ gfc_trans_deallocate (gfc_code *code)
 		  gfc_add_expr_to_block (&se.pre, tmp);
 		}
 	    }
-
-      if (expr->rank)
 	  tmp = gfc_array_deallocate (se.expr, pstat, expr);
+	}
       else
 	{
-	  tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
+	  tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
+						   expr, expr->ts);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,

gcc/fortran/trans.c

@@ -945,6 +945,103 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 }
 
 
+/* Generate code for deallocation of allocatable scalars (variables or
+   components). Before the object itself is freed, any allocatable
+   subcomponents are being deallocated.  */
+
+tree
+gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
+				   gfc_expr* expr, gfc_typespec ts)
+{
+  stmtblock_t null, non_null;
+  tree cond, tmp, error;
+
+  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
+			  build_int_cst (TREE_TYPE (pointer), 0));
+
+  /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
+     we emit a runtime error.  */
+  gfc_start_block (&null);
+  if (!can_fail)
+    {
+      tree varname;
+
+      gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+      varname = gfc_build_cstring_const (expr->symtree->name);
+      varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+      error = gfc_trans_runtime_error (true, &expr->where,
+				       "Attempt to DEALLOCATE unallocated '%s'",
+				       varname);
+    }
+  else
+    error = build_empty_stmt (input_location);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       status, build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			     fold_build1_loc (input_location, INDIRECT_REF,
+					      status_type, status),
+			     build_int_cst (status_type, 1));
+      error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond2, tmp, error);
+    }
+
+  gfc_add_expr_to_block (&null, error);
+
+  /* When POINTER is not NULL, we free it.  */
+  gfc_start_block (&non_null);
+  
+  /* Free allocatable components.  */
+  if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, pointer);
+      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+  else if (ts.type == BT_CLASS
+	   && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, pointer);
+      tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
+				       tmp, 0);
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+  
+  tmp = build_call_expr_loc (input_location,
+			 built_in_decls[BUILT_IN_FREE], 1,
+			 fold_convert (pvoid_type_node, pointer));
+  gfc_add_expr_to_block (&non_null, tmp);
+
+  if (status != NULL_TREE && !integer_zerop (status))
+    {
+      /* We set STATUS to zero if it is present.  */
+      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree cond2;
+
+      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			       status, build_int_cst (TREE_TYPE (status), 0));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			     fold_build1_loc (input_location, INDIRECT_REF,
+					      status_type, status),
+			     build_int_cst (status_type, 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
+			     tmp, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&non_null, tmp);
+    }
+
+  return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			  gfc_finish_block (&null),
+			  gfc_finish_block (&non_null));
+}
+
+
 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
    following pseudo-code:
 

gcc/fortran/trans.h

@@ -532,6 +532,7 @@ tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
+tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
 
 /* Generate code to call realloc().  */
 tree gfc_call_realloc (stmtblock_t *, tree, tree);

gcc/testsuite/ChangeLog

+2010-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/42647
+	* gfortran.dg/allocatable_scalar_9.f90: Extended.
+	* gfortran.dg/allocatable_scalar_10.f90: New.
+	* gfortran.dg/class_19.f03: Extended.
+
 2010-10-26  Jan Hubicka  <jh@suse.cz>
 
 	PR middle-end/45736

gcc/testsuite/gfortran.dg/allocatable_scalar_10.f90

+! { dg-do run }
+!
+! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+type t
+ integer, allocatable :: p
+end type t
+type(t), allocatable :: a
+
+deallocate(a,stat=istat)
+if (istat == 0) call abort()
+end 

gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90

 ! { dg-do run }
+! { dg-options "-fdump-tree-original" }
 !
 ! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component
 !
@@ -48,4 +49,7 @@ if(allocated(na3%b3)) call abort()
 if(allocated(na4%b4)) call abort()
 end
 
+! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
 ! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/class_19.f03

 ! { dg-do run }
+! { dg-options "-fdump-tree-original" }
 !
 ! PR 43969: [OOP] ALLOCATED() with polymorphic variables
 !
@@ -38,4 +39,7 @@ program main
 
 end program main
 
+! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+
 ! { dg-final { cleanup-modules "foo_mod" } }