re PR fortran/41586 ([OOP] Allocatable _scalars_ are never auto-deallocated)

2009-10-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41586
	* parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
	for CLASS variables.
	* trans-array.c (structure_alloc_comps): Handle deallocation and
	nullification of allocatable scalar components.
	* trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
	automatic deallocation.
	(gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.


2009-10-19  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41586
	* gfortran.dg/auto_dealloc_1.f90: New test case.

From-SVN: r152988

gcc/fortran/ChangeLog

+2009-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41586
+	* parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
+	for CLASS variables.
+	* trans-array.c (structure_alloc_comps): Handle deallocation and
+	nullification of allocatable scalar components.
+	* trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
+	automatic deallocation.
+	(gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.
+
 2009-10-19  Tobias Burnus  <burnus@net-b.de>
 	    Steven G. Kargl  <kargl@gcc.gnu.org>
 

gcc/fortran/parse.c

@@ -2068,11 +2068,15 @@ endType:
     {
       /* Look for allocatable components.  */
       if (c->attr.allocatable
+	  || (c->ts.type == BT_CLASS
+	      && c->ts.u.derived->components->attr.allocatable)
 	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
 	sym->attr.alloc_comp = 1;
 
       /* Look for pointer components.  */
       if (c->attr.pointer
+	  || (c->ts.type == BT_CLASS
+	      && c->ts.u.derived->components->attr.pointer)
 	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
 	sym->attr.pointer_comp = 1;
 

gcc/fortran/trans-array.c

@@ -5906,6 +5906,36 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      tmp = gfc_trans_dealloc_allocated (comp);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
+	  else if (c->attr.allocatable)
+	    {
+	      /* Allocatable scalar components.  */
+	      comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+
+	      tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+				 build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->ts.type == BT_CLASS
+		   && c->ts.u.derived->components->attr.allocatable)
+	    {
+	      /* Allocatable scalar CLASS components.  */
+	      comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+	      
+	      /* Add reference to '$data' component.  */
+	      tmp = c->ts.u.derived->components->backend_decl;
+	      comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+				  comp, tmp, NULL_TREE);
+
+	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+
+	      tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+				 build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
 	  break;
 
 	case NULLIFY_ALLOC_COMP:
@@ -5917,6 +5947,27 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				  decl, cdecl, NULL_TREE);
 	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
 	    }
+	  else if (c->attr.allocatable)
+	    {
+	      /* Allocatable scalar components.  */
+	      comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+	      tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+				 build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->ts.type == BT_CLASS
+		   && c->ts.u.derived->components->attr.allocatable)
+	    {
+	      /* Allocatable scalar CLASS components.  */
+	      comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+	      /* Add reference to '$data' component.  */
+	      tmp = c->ts.u.derived->components->backend_decl;
+	      comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+				  comp, tmp, NULL_TREE);
+	      tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+				 build_int_cst (TREE_TYPE (comp), 0));
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
           else if (cmp_has_alloc_comps)
 	    {
 	      comp = fold_build3 (COMPONENT_REF, ctype,

gcc/fortran/trans-decl.c

@@ -1187,22 +1187,23 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       /* Create variables to hold the non-constant bits of array info.  */
       gfc_build_qualified_array (decl, sym);
 
-      /* Remember this variable for allocation/cleanup.  */
-      gfc_defer_symbol_init (sym);
-
       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
 	GFC_DECL_PACKED_ARRAY (decl) = 1;
     }
 
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
-    gfc_defer_symbol_init (sym);
-  /* This applies a derived type default initializer.  */
-  else if (sym->ts.type == BT_DERIVED
-	     && sym->attr.save == SAVE_NONE
-	     && !sym->attr.data
-	     && !sym->attr.allocatable
-	     && (sym->value && !sym->ns->proc_name->attr.is_main_program)
-	     && !sym->attr.use_assoc)
+  /* Remember this variable for allocation/cleanup.  */
+  if (sym->attr.dimension || sym->attr.allocatable
+      || (sym->ts.type == BT_CLASS &&
+	  (sym->ts.u.derived->components->attr.dimension
+	   || sym->ts.u.derived->components->attr.allocatable))
+      || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+      /* This applies a derived type default initializer.  */
+      || (sym->ts.type == BT_DERIVED
+	  && sym->attr.save == SAVE_NONE
+	  && !sym->attr.data
+	  && !sym->attr.allocatable
+	  && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+	  && !sym->attr.use_assoc))
     gfc_defer_symbol_init (sym);
 
   gfc_finish_var_decl (decl, sym);
@@ -3054,7 +3055,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
     Allocation and initialization of array variables.
     Allocation of character string variables.
     Initialization and possibly repacking of dummy arrays.
-    Initialization of ASSIGN statement auxiliary variable.  */
+    Initialization of ASSIGN statement auxiliary variable.
+    Automatic deallocation.  */
 
 tree
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
@@ -3182,6 +3184,37 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	}
       else if (sym_has_alloc_comp)
 	fnbody = gfc_trans_deferred_array (sym, fnbody);
+      else if (sym->attr.allocatable
+	       || (sym->ts.type == BT_CLASS
+		   && sym->ts.u.derived->components->attr.allocatable))
+	{
+	  /* Automatic deallocatation of allocatable scalars.  */
+	  tree tmp;
+	  gfc_expr *e;
+	  gfc_se se;
+	  stmtblock_t block;
+	  
+	  e = gfc_lval_expr_from_sym (sym);
+	  if (sym->ts.type == BT_CLASS)
+	    gfc_add_component_ref (e, "$data");
+
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, e);
+	  gfc_free_expr (e);
+
+	  gfc_start_block (&block);
+	  gfc_add_expr_to_block (&block, fnbody);
+
+	  tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+			     se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  fnbody = gfc_finish_block (&block);
+	}
       else if (sym->ts.type == BT_CHARACTER)
 	{
 	  gfc_get_backend_locus (&loc);

gcc/testsuite/ChangeLog

+2009-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41586
+	* gfortran.dg/auto_dealloc_1.f90: New test case.
+
 2009-10-18  Jakub Jelinek  <jakub@redhat.com>
 
 	Port from redhat/gcc-4_4-branch:

gcc/testsuite/gfortran.dg/auto_dealloc_1.f90

+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR 41586: Allocatable _scalars_ are never auto-deallocated
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module automatic_deallocation
+
+  type t0
+    integer :: i
+  end type
+
+  type t1
+    real :: pi = 3.14
+    integer, allocatable :: j
+  end type
+
+  type t2
+    class(t0), allocatable :: k
+  end type t2
+
+contains
+
+  ! (1) simple allocatable scalars
+  subroutine a
+    integer, allocatable :: m
+    allocate (m)
+    m = 42
+  end subroutine
+
+  ! (2) allocatable scalar CLASS variables
+  subroutine b
+    class(t0), allocatable :: m
+    allocate (t0 :: m)
+    m%i = 43
+  end subroutine
+
+  ! (3) allocatable scalar components
+  subroutine c
+    type(t1) :: m
+    allocate (m%j)
+    m%j = 44
+  end subroutine
+
+  ! (4) allocatable scalar CLASS components
+  subroutine d
+    type(t2) :: m
+    allocate (t0 :: m%k)
+    m%k%i = 45
+  end subroutine
+
+end module 
+
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+
+! { dg-final { cleanup-modules "automatic_deallocation" } }
+! { dg-final { cleanup-tree-dump "original" } }