git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Tobias Burnus 2013-06-08 14:26:40 +02:00 committed by Tobias Burnus
parent cc6be82ef7
commit ed3f1ef2ba
6 changed files with 334 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -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

65
gcc/fortran/trans-decl.c
View File

@ -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))
{
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;
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));
}
gfc_add_expr_to_block (&init, tmp);
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);
}
else if (f->sym->value)
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 (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));
}
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)
{

7
gcc/testsuite/ChangeLog
View File

@ -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

3
gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
View File

@ -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" } }

39
gcc/testsuite/gfortran.dg/finalize_10.f90 Normal file
View File

@ -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" } }

238
gcc/testsuite/gfortran.dg/finalize_15.f90 Normal file
View File

@ -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