2013-06-06 Tobias Burnus PR fortran/37336 * trans-decl.c (init_intent_out_dt): Call finalizer when approriate. 2013-06-06 Tobias Burnus PR fortran/37336 * gfortran.dg/finalize_10.f90: New. * gfortran.dg/auto_dealloc_2.f90: Update tree-dump. * gfortran.dg/finalize_15.f90: New. diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index b0e3ffc..72bb23f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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) { --- /dev/null 2013-06-06 09:52:08.544104880 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-06-03 12:32:38.763008261 +0200 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 index d261973..04ee7f2 100644 --- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 @@ -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" } } --- /dev/null 2013-06-06 09:52:08.544104880 +0200 +++ gcc/gcc/testsuite/gfortran.dg/finalize_15.f90 2013-05-31 22:29:58.958076041 +0200 @@ -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