[Patch, fortran] PR64932 [4.9/5 Regression] ICE in gfc_conv_descriptor_data_get for generated finalizer

[Paul Richard Thomas]

Dear All,

This is a slight development of the patch posted on the PR itself.

class.c(finalize_component) is not able to deal correctly with
non-allocatable, derived type array components that have allocatable
components. Rather than generating loops in finalize_component,  the
condition is detected in trans-stmt.c(gfc_trans_deallocate) and
gfc_deallocate_alloc_comp is called after obtaining the derived type
for the array and checking that it is not finalizable.

Happily, this fix does not generate the error:
Error: Two or more part references with nonzero rank must not be
specified at (1)
which occurs if the code is written explicitly.

Bootstraps and regtests on FC21/x86_64

OK for trunk and 4.9?

Paul

2015-02-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/64932
    * trans-stmt.c (gfc_trans_deallocate): If a component array
    expression is not a descriptor type and it is a derived type
    that has allocatable components and is not finalizable, then
    deallocate the allocatable components.

2015-02-07  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/6432
    * gfortran.dg/finalize_28.f90: New test
-------------- next part --------------
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 220481)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_deallocate (gfc_code *code)
*** 5575,5585 ****
  
        if (expr->rank || gfc_is_coarray (expr))
  	{
  	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
  	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
  	    {
- 	      gfc_ref *ref;
  	      gfc_ref *last = NULL;
  	      for (ref = expr->ref; ref; ref = ref->next)
  		if (ref->type == REF_COMPONENT)
  		  last = ref;
--- 5575,5587 ----
  
        if (expr->rank || gfc_is_coarray (expr))
  	{
+ 	  gfc_ref *ref;
+ 
  	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
  	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
  	    {
  	      gfc_ref *last = NULL;
+ 
  	      for (ref = expr->ref; ref; ref = ref->next)
  		if (ref->type == REF_COMPONENT)
  		  last = ref;
*************** gfc_trans_deallocate (gfc_code *code)
*** 5590,5602 ****
  		    && !(!last && expr->symtree->n.sym->attr.pointer))
  		{
  		  tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
! 						  expr->rank);
  		  gfc_add_expr_to_block (&se.pre, tmp);
  		}
  	    }
! 	  tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
! 				      label_finish, expr);
! 	  gfc_add_expr_to_block (&se.pre, tmp);
  	  if (al->expr->ts.type == BT_CLASS)
  	    gfc_reset_vptr (&se.pre, al->expr);
  	}
--- 5592,5636 ----
  		    && !(!last && expr->symtree->n.sym->attr.pointer))
  		{
  		  tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
! 						   expr->rank);
  		  gfc_add_expr_to_block (&se.pre, tmp);
  		}
  	    }
! 
! 	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
! 	    {
! 	      tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
! 				          label_finish, expr);
! 	      gfc_add_expr_to_block (&se.pre, tmp);
! 	    }
! 	  else if (TREE_CODE (se.expr) == COMPONENT_REF
! 		   && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE
! 		   && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr)))
! 			== RECORD_TYPE)
! 	    {
! 	      /* class.c(finalize_component) generates these, when a
! 		 finalizable entity has a non-allocatable derived type array
! 		 component, which has allocatable components. Obtain the
! 		 derived type of the array and deallocate the allocatable
! 		 components. */
! 	      for (ref = expr->ref; ref; ref = ref->next)
! 		{
! 		  if (ref->u.c.component->attr.dimension
! 		      && ref->u.c.component->ts.type == BT_DERIVED)
! 		    break;
! 		}
! 
! 	      if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp
! 		  && !gfc_is_finalizable (ref->u.c.component->ts.u.derived,
! 					  NULL))
! 		{
! 		  tmp = gfc_deallocate_alloc_comp
! 				(ref->u.c.component->ts.u.derived,
! 				 se.expr, expr->rank);
! 		  gfc_add_expr_to_block (&se.pre, tmp);
! 		}
! 	    }
! 
  	  if (al->expr->ts.type == BT_CLASS)
  	    gfc_reset_vptr (&se.pre, al->expr);
  	}
Index: gcc/testsuite/gfortran.dg/finalize_28.f90
===================================================================
*** gcc/testsuite/gfortran.dg/finalize_28.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/finalize_28.f90	(working copy)
***************
*** 0 ****
--- 1,24 ----
+ ! { dg-do compile }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR64932.
+ !
+ ! Reported by Daniel Shapiro  <shapero@uw.edu>
+ !
+ module coo_graphs
+   implicit none
+   type :: dynamic_array
+     integer :: length, capacity, min_capacity
+     integer, allocatable :: array(:)
+   end type
+   type :: coo_graph
+     type(dynamic_array) :: edges(2)
+     integer, private :: ne
+   end type coo_graph
+ contains
+   subroutine coo_dump_edges(g, edges)
+     class(coo_graph), intent(in) :: g
+     integer, intent(out) :: edges(:,:)
+   end subroutine coo_dump_edges
+ end module coo_graphs
+ ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }