re PR fortran/37336 ([F03] Finish derived-type finalization)

2013-06-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/37336
        * trans-decl.c (init_intent_out_dt): Call finalizer
        when approriate.

2013-06-08  Tobias Burnus  <burnus@net-b.de>

        PR fortran/37336
        * gfortran.dg/finalize_10.f90: New.
        * gfortran.dg/auto_dealloc_2.f90: Update tree-dump.
        * gfortran.dg/finalize_15.f90: New.

From-SVN: r199851

gcc/fortran/ChangeLog

@@ -1,3 +1,9 @@
+2013-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* trans-decl.c (init_intent_out_dt): Call finalizer
+	when approriate.
+
 2013-06-08  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/57553

gcc/fortran/trans-decl.c

@@ -3501,38 +3501,57 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	&& !f->sym->attr.pointer
 	&& f->sym->ts.type == BT_DERIVED)
       {
-	if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+	tmp = NULL_TREE;
+
+	/* Note: Allocatables are excluded as they are already handled
+	   by the caller.  */
+	if (!f->sym->attr.allocatable
+	    && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
 	  {
+	    stmtblock_t block;
+	    gfc_expr *e;
+
+	    gfc_init_block (&block);
+	    f->sym->attr.referenced = 1;
+	    e = gfc_lval_expr_from_sym (f->sym);
+	    gfc_add_finalizer_call (&block, e);
+	    gfc_free_expr (e);
+	    tmp = gfc_finish_block (&block);
+	  }
+
+	if (tmp == NULL_TREE && !f->sym->attr.allocatable
+	    && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
 	  tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
 					   f->sym->backend_decl,
 					   f->sym->as ? f->sym->as->rank : 0);
 
-	    if (f->sym->attr.optional
+	if (tmp != NULL_TREE && (f->sym->attr.optional
-		|| f->sym->ns->proc_name->attr.entry_master)
+				 || f->sym->ns->proc_name->attr.entry_master))
 	  {
 	    present = gfc_conv_expr_present (f->sym);
 	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
-				  present, tmp,
+			      present, tmp, build_empty_stmt (input_location));
-				  build_empty_stmt (input_location));
 	  }
 
+	if (tmp != NULL_TREE)
 	  gfc_add_expr_to_block (&init, tmp);
-	  }
+	else if (f->sym->value && !f->sym->attr.allocatable)
-       else if (f->sym->value)
 	  gfc_init_default_dt (f->sym, &init, true);
       }
     else if (f->sym && f->sym->attr.intent == INTENT_OUT
 	     && f->sym->ts.type == BT_CLASS
 	     && !CLASS_DATA (f->sym)->attr.class_pointer
-	     && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+	     && !CLASS_DATA (f->sym)->attr.allocatable)
       {
-	tmp = gfc_class_data_get (f->sym->backend_decl);
+	stmtblock_t block;
-	if (CLASS_DATA (f->sym)->as == NULL)
+	gfc_expr *e;
-	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
-	tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
+	gfc_init_block (&block);
-					 tmp,
+	f->sym->attr.referenced = 1;
-					 CLASS_DATA (f->sym)->as ?
+	e = gfc_lval_expr_from_sym (f->sym);
-					 CLASS_DATA (f->sym)->as->rank : 0);
+	gfc_add_finalizer_call (&block, e);
+	gfc_free_expr (e);
+	tmp = gfc_finish_block (&block);
 
 	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
 	  {

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2013-06-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/37336
+	* gfortran.dg/finalize_10.f90: New.
+	* gfortran.dg/auto_dealloc_2.f90: Update tree-dump.
+	* gfortran.dg/finalize_15.f90: New.
+
 2013-06-08  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/57553

gcc/testsuite/gfortran.dg/auto_dealloc_2.f90

@@ -26,5 +26,6 @@ contains
 
 end program 
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/finalize_10.f90

@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+! Finalize nonallocatable INTENT(OUT)
+!
+module m
+  type t
+  end type t
+  type t2
+  contains
+    final :: fini
+  end type t2
+contains
+  elemental subroutine fini(var)
+    type(t2), intent(inout) :: var
+  end subroutine fini
+end module m
+
+subroutine foo(x,y,aa,bb)
+  use m
+  class(t), intent(out) :: x(:),y
+  type(t2), intent(out) :: aa(:),bb
+end subroutine foo
+
+! Finalize CLASS + set default init
+! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
+
+! FINALIZE TYPE:
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&parm.\[0-9\]+, 0, 0);" 1 "original" } }
+! { dg!final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&desc.\[0-9\]+, 0, 0);" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/finalize_15.f90

@@ -0,0 +1,238 @@
+! { dg-do run }
+!
+! PR fortran/37336
+!
+! Check the scalarizer/array packing with strides
+! in the finalization wrapper
+!
+module m
+  implicit none
+
+  type t1
+    integer :: i
+  contains
+    final :: fini_elem
+  end type t1
+
+  type, extends(t1) :: t1e
+    integer :: j
+  contains
+    final :: fini_elem2
+  end type t1e
+
+  type t2
+    integer :: i
+  contains
+    final :: fini_shape
+  end type t2
+
+  type, extends(t2) :: t2e
+    integer :: j
+  contains
+    final :: fini_shape2
+  end type t2e
+
+  type t3
+    integer :: i
+  contains
+    final :: fini_explicit
+  end type t3
+
+  type, extends(t3) :: t3e
+    integer :: j
+  contains
+    final :: fini_explicit2
+  end type t3e
+
+  integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e
+
+contains
+
+  impure elemental subroutine fini_elem(x)
+    type(t1), intent(inout) :: x
+    integer :: i, j, i2, j2
+
+    if (cnt1e /= 5*4) call abort ()
+    j = mod (cnt1,5)+1
+    i = cnt1/5 + 1
+    i2 = (i-1)*3 + 1
+    j2 = (j-1)*2 + 1
+    if (x%i /= j2 + 100*i2) call abort ()
+    x%i = x%i * (-13)
+    cnt1 = cnt1 + 1
+  end subroutine fini_elem
+
+  impure elemental subroutine fini_elem2(x)
+    type(t1e), intent(inout) :: x
+    integer :: i, j, i2, j2
+
+    j = mod (cnt1e,5)+1
+    i = cnt1e/5 + 1
+    i2 = (i-1)*3 + 1
+    j2 = (j-1)*2 + 1
+    if (x%i /= j2 + 100*i2) call abort ()
+    if (x%j /= (j2 + 100*i2)*100) call abort ()
+    x%j = x%j * (-13)
+    cnt1e = cnt1e + 1
+  end subroutine fini_elem2
+
+  subroutine fini_shape(x)
+    type(t2) :: x(:,:)
+    if (cnt2e /= 1 .or. cnt2 /= 0) call abort ()
+    call check_var_sec(x%i, 1)
+    x%i = x%i * (-13)
+    cnt2 = cnt2 + 1
+  end subroutine fini_shape
+
+  subroutine fini_shape2(x)
+    type(t2e) :: x(:,:)
+    call check_var_sec(x%i, 1)
+    call check_var_sec(x%j, 100)
+    x%j = x%j * (-13)
+    cnt2e = cnt2e + 1
+  end subroutine fini_shape2
+
+  subroutine fini_explicit(x)
+    type(t3) :: x(5,4)
+    if (cnt3e /= 1 .or. cnt3 /= 0) call abort ()
+    call check_var_sec(x%i, 1)
+    x%i = x%i * (-13)
+    cnt3 = cnt3 + 1
+  end subroutine fini_explicit
+
+  subroutine fini_explicit2(x)
+    type(t3e) :: x(5,4)
+    call check_var_sec(x%i, 1)
+    call check_var_sec(x%j, 100)
+    x%j = x%j * (-13)
+    cnt3e = cnt3e + 1
+  end subroutine fini_explicit2
+
+  subroutine fin_test_1(x)
+    class(t1), intent(out) :: x(5,4)
+  end subroutine fin_test_1
+
+  subroutine fin_test_2(x)
+    class(t2), intent(out) :: x(:,:)
+  end subroutine fin_test_2
+
+  subroutine fin_test_3(x)
+    class(t3), intent(out) :: x(:,:)
+    if (any (shape(x) /= [5,4])) call abort ()
+  end subroutine fin_test_3
+
+  subroutine check_var_sec(x, factor)
+    integer :: x(:,:)
+    integer, value :: factor
+    integer :: i, j, i2, j2
+
+    do i = 1, 4
+      i2 = (i-1)*3 + 1
+      do j = 1, 5
+        j2 = (j-1)*2 + 1
+        if (x(j,i) /= (j2 + 100*i2)*factor) call abort ()
+      end do
+    end do
+  end subroutine check_var_sec
+end module m
+
+
+program test
+  use m
+  implicit none
+
+  class(t1), allocatable :: x(:,:)
+  class(t2), allocatable :: y(:,:)
+  class(t3), allocatable :: z(:,:)
+  integer :: i, j
+
+  cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0;  cnt3 = 0; cnt3e = 0
+
+  allocate (t1e :: x(10,10))
+  allocate (t2e :: y(10,10))
+  allocate (t3e :: z(10,10))
+
+  select type(x)
+    type is (t1e)
+      do i = 1, 10
+        do j = 1, 10
+          x(j,i)%i = j + 100*i
+          x(j,i)%j = (j + 100*i)*100
+        end do
+      end do
+  end select
+
+  select type(y)
+    type is (t2e)
+      do i = 1, 10
+        do j = 1, 10
+          y(j,i)%i = j + 100*i
+          y(j,i)%j = (j + 100*i)*100
+        end do
+      end do
+  end select
+
+  select type(z)
+    type is (t3e)
+      do i = 1, 10
+        do j = 1, 10
+          z(j,i)%i = j + 100*i
+          z(j,i)%j = (j + 100*i)*100
+        end do
+      end do
+  end select
+
+  if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
+
+  call fin_test_1(x(::2,::3))
+  if (cnt1 /= 5*4) call abort ()
+  if (cnt1e /= 5*4) call abort ()
+  cnt1 = 0; cnt1e = 0
+  if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
+
+  call fin_test_2(y(::2,::3))
+  if (cnt2 /= 1) call abort ()
+  if (cnt2e /= 1) call abort ()
+  cnt2 = 0; cnt2e = 0
+  if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) call abort()
+
+  call fin_test_3(z(::2,::3))
+  if (cnt3 /= 1) call abort ()
+  if (cnt3e /= 1) call abort ()
+  cnt3 = 0; cnt3e = 0
+  if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) call abort()
+
+  select type(x)
+    type is (t1e)
+      call check_val(x%i, 1)
+      call check_val(x%j, 100)
+  end select
+
+  select type(y)
+    type is (t2e)
+      call check_val(y%i, 1)
+      call check_val(y%j, 100)
+  end select
+
+  select type(z)
+    type is (t3e)
+      call check_val(z%i, 1)
+      call check_val(z%j, 100)
+  end select
+
+contains
+  subroutine check_val(x, factor)
+    integer :: x(:,:)
+    integer, value :: factor
+    integer :: i, j
+    do i = 1, 10
+      do j = 1, 10
+        if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
+          if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort ()
+        else
+          if (x(j,i) /= (j + 100*i)*factor) call abort ()
+        end if
+      end do
+    end do
+  end subroutine check_val
+end program test