2013-06-06 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans-decl.c (init_intent_out_dt): Call finalizer
when approriate.
2013-06-06 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.
@@ -3501,38 +3503,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))
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ 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 (f->sym->attr.optional
- || 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,
- build_empty_stmt (input_location));
- }
+ 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);
- gfc_add_expr_to_block (&init, tmp);
+ if (tmp != NULL_TREE && (f->sym->attr.optional
+ || 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, build_empty_stmt (input_location));
}
- else if (f->sym->value)
+
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&init, tmp);
+ else if (f->sym->value && !f->sym->attr.allocatable)
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);
- if (CLASS_DATA (f->sym)->as == NULL)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
- tmp,
- CLASS_DATA (f->sym)->as ?
- CLASS_DATA (f->sym)->as->rank : 0);
+ 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 (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
{
@@ -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" } }
@@ -25,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" } }
@@ -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