diff mbox

[Fortran,v1] Fix deallocation of nested derived typed components

Message ID 20161202132840.1ca6be4b@vepi2
State Superseded
Headers show

Commit Message

Andre Vehreschild Dec. 2, 2016, 12:28 p.m. UTC 
Hi all,

attached patch fixes on ICE, when freeing a scalar allocatable component in a
derived typed coarray.

Furthermore does it fix freeing of nested derived typed allocatable components.
A simple code explains the bug that is solved by the patch:

type inner
  integer, allocatable :: i
end type
type outer
  type(inner), allocatable :: link
end type

type(outer), allocatable :: obj

allocate(obj)
allocate(obj%link)
allocate(obj%link%i)

deallocate(obj%link)
deallocate(obj) ! <- this will generate pseudo-pseudo-code of the kind:

if (obj.link.i != 0)  // But link is already NULL, i.e. a crash occurs.
  free(obj.link.i)

The patch fixes this by moving the code for freeing link.i into the check if
link is allocated, i.e.:

if (obj.link != 0) {
  if (obj.link.i != 0)  {
    free (obj.link.i);
    obj.link.i = 0;
  }
  free (obj.link);
  obj.link = 0;
}

Furthermore does the patch ensure that the handle of an allocatable component is
set to 0.

Bootstraped and regtested ok on x86_64-linux/F23. Ok for trunk?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de
gcc/fortran/ChangeLog:

2016-12-02  Andre Vehreschild  <vehre@gcc.gnu.org>

	* trans-array.c (structure_alloc_comps): Restructure deallocation of
	(nested) allocatable components.  Insert dealloc of sub-component into
	the block guarded by the if != NULL for the component.
	* trans.c (gfc_deallocate_with_status): Allow deallocation of scalar
	and arrays as well as coarrays.
	(gfc_deallocate_scalar_with_status): Get the data member for coarrays
	only when freeing an array with descriptor.
	* trans.h: Change prototype of gfc_deallocate_with_status to allow
	adding statements into the block guarded by the if (pointer != 0) and
	supply a coarray handle.

gcc/testsuite/ChangeLog:

2016-12-02  Andre Vehreschild  <vehre@gcc.gnu.org>

	* gfortran.dg/coarray_alloc_comp_3.f08: New test.
	* gfortran.dg/finalize_18.f90: Add count for additional guard against
	accessing null-pointer.
diff mbox

Patch

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ac90a4b..a5deb42 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8157,8 +8157,11 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
   tree null_cond = NULL_TREE;
   tree add_when_allocated;
   tree dealloc_fndecl;
-  bool called_dealloc_with_status;
+  tree caf_token;
   gfc_symbol *vtab;
+  int caf_dereg_mode;
+  symbol_attribute *attr;
+  bool deallocate_called;
 
   gfc_init_block (&fnblock);
 
@@ -8265,7 +8268,8 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
       bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
 				  || c->ts.type == BT_CLASS)
 				    && c->ts.u.derived->attr.alloc_comp;
-      bool same_type = c->ts.type == BT_DERIVED && der_type == c->ts.u.derived;
+      bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
+	|| (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
 
       cdecl = c->backend_decl;
       ctype = TREE_TYPE (cdecl);
@@ -8274,112 +8278,120 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	{
 	case DEALLOCATE_ALLOC_COMP:
 
-	  /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
-	     (i.e. this function) so generate all the calls and suppress the
-	     recursion from here, if necessary.  */
-	  called_dealloc_with_status = false;
 	  gfc_init_block (&tmpblock);
 
-	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
-	      || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
-	    {
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
+	  comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				  decl, cdecl, NULL_TREE);
 
-	      /* The finalizer frees allocatable components.  */
-	      called_dealloc_with_status
-		= gfc_add_comp_finalizer_call (&tmpblock, comp, c,
-					       purpose == DEALLOCATE_ALLOC_COMP
-					       && caf_enabled (caf_mode));
-	    }
+	  /* Shortcut to get the attributes of the component.  */
+	  if (c->ts.type == BT_CLASS)
+	    attr = &CLASS_DATA (c)->attr;
 	  else
-	    comp = NULL_TREE;
+	    attr = &c->attr;
 
-	  if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
-	      && (c->attr.dimension
-		  || (caf_enabled (caf_mode)
-		      && (caf_in_coarray (caf_mode) || c->attr.codimension))))
-	    {
-	      /* Allocatable arrays or coarray'ed components (scalar or
-		 array).  */
-	      int caf_dereg_mode
-		  = (caf_in_coarray (caf_mode) || c->attr.codimension)
-		  ? (gfc_caf_is_dealloc_only (caf_mode)
-		     ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
-		     : GFC_CAF_COARRAY_DEREGISTER)
-		  : GFC_CAF_COARRAY_NOCOARRAY;
-	      if (comp == NULL_TREE)
-		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-					decl, cdecl, NULL_TREE);
+	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	    /* Call the finalizer, which will free the memory and nullify the
+	       pointer of an array.  */
+	    deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
+							 caf_enabled (caf_mode))
+		&& attr->dimension;
+	  else
+	    deallocate_called = false;
 
-	      if (c->attr.dimension || c->attr.codimension)
-		/* Deallocate array.  */
-		tmp = gfc_trans_dealloc_allocated (comp, NULL, caf_dereg_mode);
+	  /* Add the _class ref for classes.  */
+	  if (c->ts.type == BT_CLASS && attr->allocatable)
+	    comp = gfc_class_data_get (comp);
+
+	  add_when_allocated = NULL_TREE;
+	  if (cmp_has_alloc_comps
+	      && !c->attr.pointer && !c->attr.proc_pointer
+	      && !same_type
+	      && !deallocate_called)
+	    {
+	      /* Add checked deallocation of the components.  This code is
+		 obviously added because the finalizer is not trusted to free
+		 all memory.  */
+	      if (c->ts.type == BT_CLASS)
+		{
+		  rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
+		  add_when_allocated
+		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
+					       comp, NULL_TREE, rank, purpose,
+					       caf_mode);
+		}
 	      else
 		{
-		  /* Deallocate scalar.  */
-		  tree cond = fold_build2_loc (input_location, NE_EXPR,
-					       boolean_type_node, comp,
-					       build_int_cst (TREE_TYPE (comp),
-							      0));
-
-		  tmp = fold_build3_loc (input_location, COMPONENT_REF,
-					 pvoid_type_node, decl, c->caf_token,
-					 NULL_TREE);
-		  tmp = build_call_expr_loc (input_location,
-					     gfor_fndecl_caf_deregister, 5,
-					     gfc_build_addr_expr (NULL_TREE,
-								  tmp),
-					     build_int_cst (integer_type_node,
-							    caf_dereg_mode),
-					     null_pointer_node,
-					     null_pointer_node,
-					     integer_zero_node);
-		  tmp = fold_build3_loc (input_location, COND_EXPR,
-					 void_type_node, cond, tmp,
-					 build_empty_stmt (input_location));
+		  rank = c->as ? c->as->rank : 0;
+		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
+							      comp, NULL_TREE,
+							      rank, purpose,
+							      caf_mode);
 		}
-
-	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
-	  else if (c->attr.allocatable && !c->attr.codimension && !same_type)
+
+	  if (attr->allocatable && !attr->proc_pointer && !same_type
+	      && (!c->attr.codimension
+		  || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) != 0))
 	    {
-	      /* Allocatable scalar components.  */
-	      if (comp == NULL_TREE)
-		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-					decl, cdecl, NULL_TREE);
+	      /* Handle all types of components besides components of the
+		 same_type as the current one, because those would create an
+		 endless loop.  */
+	      caf_dereg_mode
+		  = ((caf_mode & GFC_STRUCTURE_CAF_MODE_IN_COARRAY) != 0
+		  || attr->codimension)
+		  ? ((caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) != 0
+		  ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+		  : GFC_CAF_COARRAY_DEREGISTER)
+		  : GFC_CAF_COARRAY_NOCOARRAY;
 
-	      tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
-						       NULL_TREE, true, NULL,
-						       c->ts);
-	      gfc_add_expr_to_block (&tmpblock, tmp);
-	      called_dealloc_with_status = true;
+	      caf_token = NULL_TREE;
+	      /* Coarray components are handled directly by
+		 deallocate_with_status.  */
+	      if (!attr->codimension
+		  && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
+		{
+		  if (c->caf_token)
+		    caf_token = fold_build3_loc (input_location, COMPONENT_REF,
+						 TREE_TYPE (c->caf_token),
+						 decl, c->caf_token, NULL_TREE);
+		  else if (attr->dimension)
+		    caf_token = gfc_conv_descriptor_token (comp);
+		}
+	      if (attr->dimension && !attr->codimension)
+		/* When this is an array but not in conjunction with a coarray
+		   then add the data-ref.  For coarray'ed arrays the data-ref
+		   is added by deallocate_with_status.  */
+		comp = gfc_conv_descriptor_data_get (comp);
+
+	      tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
+						NULL_TREE, NULL_TREE, true,
+						NULL, caf_dereg_mode,
+						add_when_allocated, caf_token);
 
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
-	  else if (c->attr.allocatable && !c->attr.codimension)
+	  else if (attr->allocatable && !attr->codimension
+		   && !deallocate_called)
 	    {
 	      /* Case of recursive allocatable derived types.  */
 	      tree is_allocated;
 	      tree ubound;
 	      tree cdesc;
-	      tree data;
 	      stmtblock_t dealloc_block;
 
 	      gfc_init_block (&dealloc_block);
+	      if (add_when_allocated)
+		gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
 
 	      /* Convert the component into a rank 1 descriptor type.  */
-	      if (comp == NULL_TREE)
-		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-					decl, cdecl, NULL_TREE);
-
-	      if (c->attr.dimension)
+	      if (attr->dimension)
 		{
 		  tmp = gfc_get_element_type (TREE_TYPE (comp));
-		  ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank);
+		  ubound = gfc_full_array_size (&dealloc_block, comp,
+						c->ts.type == BT_CLASS
+						? CLASS_DATA (c)->as->rank
+						: c->as->rank);
 		}
 	      else
 		{
@@ -8406,11 +8418,9 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					      gfc_index_zero_node, ubound);
 
 	      if (c->attr.dimension)
-		data = gfc_conv_descriptor_data_get (comp);
-	      else
-		data = comp;
+		comp = gfc_conv_descriptor_data_get (comp);
 
-	      gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data);
+	      gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
 
 	      /* Now call the deallocator.  */
 	      vtab = gfc_find_vtab (&c->ts);
@@ -8420,10 +8430,10 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
 	      dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
 							    dealloc_fndecl);
-	      tmp = build_int_cst (TREE_TYPE (data), 0);
+	      tmp = build_int_cst (TREE_TYPE (comp), 0);
 	      is_allocated = fold_build2_loc (input_location, NE_EXPR,
 					      boolean_type_node, tmp,
-					      data);
+					      comp);
 	      cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
 
 	      tmp = build_call_expr_loc (input_location,
@@ -8438,49 +8448,21 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				     build_empty_stmt (input_location));
 
 	      gfc_add_expr_to_block (&tmpblock, tmp);
-
-	      gfc_add_modify (&tmpblock, data,
-			      build_int_cst (TREE_TYPE (data), 0));
 	    }
+	  else if (add_when_allocated)
+	    gfc_add_expr_to_block (&tmpblock, add_when_allocated);
 
-	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
-		   && (!CLASS_DATA (c)->attr.codimension
-		    || !caf_enabled (caf_mode)))
+	  if (c->ts.type == BT_CLASS && attr->allocatable
+	      && (!attr->codimension
+		  || (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) == 0))
 	    {
-	      /* Allocatable CLASS components.  */
-
-	      /* Add reference to '_data' component.  */
-	      tmp = CLASS_DATA (c)->backend_decl;
-	      comp = fold_build3_loc (input_location, COMPONENT_REF,
-				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
-
-	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
-		tmp = gfc_trans_dealloc_allocated (comp, NULL,
-						CLASS_DATA (c)->attr.codimension
-						? GFC_CAF_COARRAY_DEREGISTER
-						: GFC_CAF_COARRAY_NOCOARRAY);
-	      else
-		{
-		  tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE,
-							   NULL_TREE, true,
-							   NULL,
-							   CLASS_DATA (c)->ts);
-		  gfc_add_expr_to_block (&tmpblock, tmp);
-		  called_dealloc_with_status = true;
-
-		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					 void_type_node, comp,
-					 build_int_cst (TREE_TYPE (comp), 0));
-		}
-	      gfc_add_expr_to_block (&tmpblock, tmp);
-
 	      /* Finally, reset the vptr to the declared type vtable and, if
 		 necessary reset the _len field.
 
 		 First recover the reference to the component and obtain
 		 the vptr.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				     decl, cdecl, NULL_TREE);
+				      decl, cdecl, NULL_TREE);
 	      tmp = gfc_class_vptr_get (comp);
 
 	      if (UNLIMITED_POLY (c))
@@ -8507,22 +8489,6 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		}
 	    }
 
-	  if (cmp_has_alloc_comps
-		&& !c->attr.pointer && !c->attr.proc_pointer
-		&& !same_type
-		&& !called_dealloc_with_status)
-	    {
-	      /* Do not deallocate the components of ultimate pointer
-		 components or iteratively call self if call has been made
-		 to gfc_trans_dealloc_allocated  */
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
-	      rank = c->as ? c->as->rank : 0;
-	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-					   rank, purpose, caf_mode);
-	      gfc_add_expr_to_block (&fnblock, tmp);
-	    }
-
 	  /* Now add the deallocation of this component.  */
 	  gfc_add_block_to_block (&fnblock, &tmpblock);
 	  break;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 6a1d481..a16bf92 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1281,30 +1281,55 @@  tree
 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 			    tree errlen, tree label_finish,
 			    bool can_fail, gfc_expr* expr,
-			    int coarray_dealloc_mode)
+			    int coarray_dealloc_mode, tree add_when_allocated,
+			    tree caf_token)
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
   tree status_type = NULL_TREE;
-  tree caf_decl = NULL_TREE;
+  tree token = NULL_TREE;
   gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
 
   if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
     {
-      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
-      caf_decl = pointer;
-      pointer = gfc_conv_descriptor_data_get (caf_decl);
-      STRIP_NOPS (pointer);
-      if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+      if (flag_coarray == GFC_FCOARRAY_LIB)
 	{
-	  bool comp_ref;
-	  if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
-	      && comp_ref)
-	    caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
-	  // else do a deregister as set by default.
+	  if (caf_token)
+	    token = caf_token;
+	  else
+	    {
+	      tree caf_type, caf_decl = pointer;
+	      pointer = gfc_conv_descriptor_data_get (caf_decl);
+	      caf_type = TREE_TYPE (caf_decl);
+	      STRIP_NOPS (pointer);
+	      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+		  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+		token = gfc_conv_descriptor_token (caf_decl);
+	      else if (DECL_LANG_SPECIFIC (caf_decl)
+		       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+		token = GFC_DECL_TOKEN (caf_decl);
+	      else
+		{
+		  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+			      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
+				 != NULL_TREE);
+		  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+		}
+	    }
+
+	  if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+	    {
+	      bool comp_ref;
+	      if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+		  && comp_ref)
+		caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
+	      // else do a deregister as set by default.
+	    }
+	  else
+	    caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
 	}
-      else
-	caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
+      else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+	pointer = gfc_conv_descriptor_data_get (pointer);
     }
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
@@ -1348,6 +1373,8 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
+  if (add_when_allocated)
+    gfc_add_expr_to_block (&non_null, add_when_allocated);
   gfc_add_finalizer_call (&non_null, expr);
   if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
       || flag_coarray != GFC_FCOARRAY_LIB)
@@ -1356,6 +1383,8 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 				 builtin_decl_explicit (BUILT_IN_FREE), 1,
 				 fold_convert (pvoid_type_node, pointer));
       gfc_add_expr_to_block (&non_null, tmp);
+      gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+							 0));
 
       if (status != NULL_TREE && !integer_zerop (status))
 	{
@@ -1378,8 +1407,7 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
     }
   else
     {
-      tree caf_type, token, cond2;
-      tree pstat = null_pointer_node;
+      tree cond2, pstat = null_pointer_node;
 
       if (errmsg == NULL_TREE)
 	{
@@ -1394,27 +1422,12 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 	    errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
 	}
 
-      caf_type = TREE_TYPE (caf_decl);
-
       if (status != NULL_TREE && !integer_zerop (status))
 	{
 	  gcc_assert (status_type == integer_type_node);
 	  pstat = status;
 	}
 
-      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
-	  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
-	token = gfc_conv_descriptor_token (caf_decl);
-      else if (DECL_LANG_SPECIFIC (caf_decl)
-	       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
-	token = GFC_DECL_TOKEN (caf_decl);
-      else
-	{
-	  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
-		      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
-	  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
-	}
-
       token = gfc_build_addr_expr  (NULL_TREE, token);
       gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
       tmp = build_call_expr_loc (input_location,
@@ -1431,6 +1444,8 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 			tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
       ASM_VOLATILE_P (tmp) = 1;
       gfc_add_expr_to_block (&non_null, tmp);
+      gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+							 0));
 
       if (status != NULL_TREE)
 	{
@@ -1516,7 +1531,7 @@  gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
   finalizable = gfc_add_finalizer_call (&non_null, expr);
   if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
-      if (coarray)
+      if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
 	tmp = gfc_conv_descriptor_data_get (pointer);
       else
 	tmp = build_fold_indirect_ref_loc (input_location, pointer);
@@ -1573,7 +1588,7 @@  gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
       gfc_add_expr_to_block (&non_null, tmp);
 
       /* It guarantees memory consistency within the same segment.  */
-      tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
+      tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
 			gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
 			tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ae1f156..bfc2a24 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -719,7 +719,8 @@  void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
-				 gfc_expr *, int);
+				 gfc_expr *, int, tree a = NULL_TREE,
+				 tree c = NULL_TREE);
 tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
 					gfc_typespec, bool c = false);
 
diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
new file mode 100644
index 0000000..4e9effd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08
@@ -0,0 +1,50 @@ 
+! { dg-do run }
+!
+! Contributed by Andre Vehreschild
+! Check that manually freeing components does not lead to a runtime crash,
+! when the auto-deallocation is taking care.
+
+program coarray_alloc_comp_3
+  implicit none
+
+  type dt
+    integer, allocatable :: i
+  end type dt
+
+  type linktype
+    type(dt), allocatable :: link
+  end type linktype
+
+  type(linktype), allocatable :: obj
+
+  allocate(obj)
+  allocate(obj%link)
+
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+  allocate(obj%link%i, source = 42)
+
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+  if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+  deallocate(obj%link%i)
+
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+  ! Freeing this object, lead to crash with older gfortran...
+  deallocate(obj%link)
+
+  if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+  ! ... when auto-deallocating the allocated components.
+  deallocate(obj)
+
+  if (allocated(obj)) error stop "Test failed. 'obj' still allocated."
+end program
diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90
index c8b4afc..3e64332 100644
--- a/gcc/testsuite/gfortran.dg/finalize_18.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_18.f90
@@ -33,8 +33,8 @@  end
 
 ! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
 ! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "original" } }
 
 ! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }