From: Paul Thomas Date: Sun, 25 Oct 2015 21:31:12 +0000 (+0000) Subject: re PR fortran/67171 (sourced allocation) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=6a4236ceb1020bcb8af45f2497672435d75c2c84;p=gcc.git re PR fortran/67171 (sourced allocation) 2015-01-25 Paul Thomas PR fortran/67171 * trans-array.c (structure_alloc_comps): On deallocation of class components, reset the vptr to the declared type vtable and reset the _len field of unlimited polymorphic components. *trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on allocatable component references to the right of part reference with non-zero rank and return NULL. (gfc_reset_vptr): Simplify this function by using the function gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE. (gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns NULL return. * trans-stmt.c (gfc_trans_allocate): Rely on the use of gfc_trans_assignment if expr3 is a variable expression since this deals correctly with array sections. 2015-01-25 Paul Thomas PR fortran/67171 * gfortran.dg/allocate_with_source_12.f03: New test PR fortran/61819 * gfortran.dg/allocate_with_source_13.f03: New test PR fortran/61830 * gfortran.dg/allocate_with_source_14.f03: New test From-SVN: r229303 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1a351be0fe1..668013d7dcd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,8 +1,25 @@ +2015-01-25 Paul Thomas + + PR fortran/67171 + * trans-array.c (structure_alloc_comps): On deallocation of + class components, reset the vptr to the declared type vtable + and reset the _len field of unlimited polymorphic components. + *trans-expr.c (gfc_find_and_cut_at_last_class_ref): Bail out on + allocatable component references to the right of part reference + with non-zero rank and return NULL. + (gfc_reset_vptr): Simplify this function by using the function + gfc_get_vptr_from_expr. Return if the vptr is NULL_TREE. + (gfc_reset_len): If gfc_find_and_cut_at_last_class_ref returns + NULL return. + * trans-stmt.c (gfc_trans_allocate): Rely on the use of + gfc_trans_assignment if expr3 is a variable expression since + this deals correctly with array sections. + 2015-10-25 Andre Vehreschild PR fortran/66927 - PR fortran/67044 - * trans-array.c (build_array_ref): Modified call to + PR fortran/67044 + * trans-array.c (build_array_ref): Modified call to gfc_get_class_array_ref to adhere to new interface. (gfc_conv_expr_descriptor): For one-based arrays that are filled by a loop starting at one the start index of the diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 45c18a5b418..b726998cfcd 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8024,6 +8024,38 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); } gfc_add_expr_to_block (&tmpblock, tmp); + + /* Finally, reset the vptr to the declared type vtable and, if + necessary reset the _len field. + + First recover the reference to the component and obtain + the vptr. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + tmp = gfc_class_vptr_get (comp); + + if (UNLIMITED_POLY (c)) + { + /* Both vptr and _len field should be nulled. */ + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = gfc_class_len_get (comp); + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } + else + { + /* Build the vtable address and set the vptr with it. */ + tree vtab; + gfc_symbol *vtable; + vtable = gfc_find_derived_vtab (c->ts.u.derived); + vtab = vtable->backend_decl; + if (vtab == NULL_TREE) + vtab = gfc_get_symbol_decl (vtable); + vtab = gfc_build_addr_expr (NULL, vtab); + vtab = fold_convert (TREE_TYPE (tmp), vtab); + gfc_add_modify (&tmpblock, tmp, vtab); + } } if (cmp_has_alloc_comps diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9585de6284d..f8ed0df8beb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -271,15 +271,29 @@ gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *e) { gfc_expr *base_expr; - gfc_ref *ref, *class_ref, *tail; + gfc_ref *ref, *class_ref, *tail, *array_ref; /* Find the last class reference. */ class_ref = NULL; + array_ref = NULL; for (ref = e->ref; ref; ref = ref->next) { + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) + array_ref = ref; + if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS) + { + /* Component to the right of a part reference with nonzero rank + must not have the ALLOCATABLE attribute. If attempts are + made to reference such a component reference, an error results + followed by anICE. */ + if (array_ref + && CLASS_DATA (ref->u.c.component)->attr.allocatable) + return NULL; class_ref = ref; + } if (ref->next == NULL) break; @@ -320,47 +334,37 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) void gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) { - gfc_expr *rhs, *lhs = gfc_copy_expr (e); gfc_symbol *vtab; - tree tmp; - gfc_ref *ref; + tree vptr; + tree vtable; + gfc_se se; - /* If we have a class array, we need go back to the class - container. */ - if (lhs->ref && lhs->ref->next && !lhs->ref->next->next - && lhs->ref->next->type == REF_ARRAY - && lhs->ref->next->u.ar.type == AR_FULL - && lhs->ref->type == REF_COMPONENT - && strcmp (lhs->ref->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (lhs->ref); - lhs->ref = NULL; - } + /* Evaluate the expression and obtain the vptr from it. */ + gfc_init_se (&se, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&se, e); else - for (ref = lhs->ref; ref; ref = ref->next) - if (ref->next && ref->next->next && !ref->next->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->next->u.ar.type == AR_FULL - && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (ref->next); - ref->next = NULL; - } + gfc_conv_expr (&se, e); + gfc_add_block_to_block (block, &se.pre); + vptr = gfc_get_vptr_from_expr (se.expr); - gfc_add_vptr_component (lhs); + /* If a vptr is not found, we can do nothing more. */ + if (vptr == NULL_TREE) + return; if (UNLIMITED_POLY (e)) - rhs = gfc_get_null_expr (NULL); + gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); else { + /* Return the vptr to the address of the declared type. */ vtab = gfc_find_derived_vtab (e->ts.u.derived); - rhs = gfc_lval_expr_from_sym (vtab); + vtable = vtab->backend_decl; + if (vtable == NULL_TREE) + vtable = gfc_get_symbol_decl (vtab); + vtable = gfc_build_addr_expr (NULL, vtable); + vtable = fold_convert (TREE_TYPE (vptr), vtable); + gfc_add_modify (block, vptr, vtable); } - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (block, tmp); - gfc_free_expr (lhs); - gfc_free_expr (rhs); } @@ -372,6 +376,8 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr) gfc_expr *e; gfc_se se_len; e = gfc_find_and_cut_at_last_class_ref (expr); + if (e == NULL) + return; gfc_add_len_component (e); gfc_init_se (&se_len, NULL); gfc_conv_expr (&se_len, e); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1bd131e7f8b..85558f0e892 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5379,8 +5379,13 @@ gfc_trans_allocate (gfc_code * code) will benefit of every enhancements gfc_trans_assignment () gets. No need to check whether e3_is is E3_UNSET, because that is - done by expr3 != NULL_TREE. */ - if (e3_is != E3_MOLD && expr3 != NULL_TREE + done by expr3 != NULL_TREE. + Exclude variables since the following block does not handle + array sections. In any case, there is no harm in sending + variables to gfc_trans_assignment because there is no + evaluation of variables. */ + if (code->expr3->expr_type != EXPR_VARIABLE + && e3_is != E3_MOLD && expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 80242736f2b..8ecfd096781 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2015-01-25 Paul Thomas + + PR fortran/67171 + * gfortran.dg/allocate_with_source_12.f03: New test + + PR fortran/61819 + * gfortran.dg/allocate_with_source_13.f03: New test + + PR fortran/61830 + * gfortran.dg/allocate_with_source_14.f03: New test + 2015-10-25 John David Anglin * g++.dg/Wno-frame-address.C: Skip on hppa*-*-*. diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 new file mode 100644 index 00000000000..76deb6174db --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_12.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Checks the fix for PR67171, where the second ALLOCATE with and array section +! SOURCE produced a zero index based temporary, which threw the assignment. +! +! Contributed by Anton Shterenlikht +! +program z + implicit none + integer, parameter :: DIM1_SIZE = 10 + real, allocatable :: d(:,:), tmp(:,:) + integer :: i, errstat + + allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat ) + + d(:,1) = [( real (i), i=1,DIM1_SIZE)] + d(:,2) = [( real(2*i), i=1,DIM1_SIZE)] +! write (*,*) d(1, :) + + call move_alloc (from = d, to = tmp) +! write (*,*) tmp( 1, :) + + allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat) + if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) call abort + deallocate (d) + + allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat) + if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) call abort + + deallocate (tmp , d) + +contains + function foo (arg) result (res) + real :: arg(:,:) + real :: res(size (arg, 1), size (arg, 2)) + res = arg + end function +end program z diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 new file mode 100644 index 00000000000..27b5c1775bc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_13.f03 @@ -0,0 +1,220 @@ +! { dg-do compile } +! +! Tests the fix for PR61819. +! +! Contributed by Salvatore Filippone +! +module foo_base_mod + integer, parameter :: foo_ipk_ = kind(1) + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer(foo_ipk_) :: nl=-1 + end type foo_desc_type + + +contains + + subroutine foo_init(ictxt) + integer :: ictxt + end subroutine foo_init + + + subroutine foo_exit(ictxt) + integer :: ictxt + end subroutine foo_exit + + subroutine foo_info(ictxt,iam,np) + integer(foo_ipk_) :: ictxt,iam,np + iam = 0 + np = 1 + end subroutine foo_info + + subroutine foo_cdall(ictxt,map,info,nl) + integer(foo_ipk_) :: ictxt, info + type(foo_desc_type) :: map + integer(foo_ipk_), optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + subroutine foo_cdasb(map,info) + integer(foo_ipk_) :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) & + & deallocate(this%v) + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer(foo_ipk_) :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer(foo_ipk_), parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer(foo_ipk_) ,save :: NumMy_xy_planes + integer(foo_ipk_) ,parameter :: NumGlobalElements = nx*ny*nz + integer(foo_ipk_) ,parameter :: NumGlobal_xy_planes = nz, Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(ictxt,NumMyElements,info) + integer(foo_ipk_) :: ictxt, NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(ictxt,map,info,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field(comm) result(this) + type(scalar_field) :: this + integer(foo_ipk_) ,intent(in) :: comm + real(foo_dpk_) ,allocatable :: f_v(:) + integer(foo_ipk_) :: i,j,k,NumMyElements, iam, np, info,ip + integer(foo_ipk_), allocatable :: idxs(:) + call foo_info(comm,iam,np) + NumMy_xy_planes = NumGlobal_xy_planes/np + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(comm,NumMyElements,info) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer(foo_ipk_) ::info + write(0,*) 'Freeing scalar_this%f' + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod, only : scalar_field,new_scalar_field + implicit none + type vector_field + type(scalar_field) :: u(1) + contains + procedure :: free + end type +contains + function new_vector_field(comm_in) result(this) + type(vector_field) :: this + integer(foo_ipk_), intent(in) :: comm_in + this%u = [new_scalar_field(comm_in)] ! Removing this line eliminates the memory leak + end function + + subroutine free(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + write(0,*) 'Freeing vector_this%u(',i,')' + call vf(i)%free() + end do + end associate + end subroutine free + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod,only: vector_field,new_vector_field + use foo_scalar_field_mod,only: map + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer(foo_ipk_) :: ictxt, iam, np, i,info + call foo_init(ictxt) + call foo_info(ictxt,iam,np) + u = new_vector_field(ictxt) + call u%free() + do i=1,10 + u = new_vector_field(ictxt) + call u%free() + end do + call u%free() + call foo_exit(ictxt) +end program diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 new file mode 100644 index 00000000000..36c1245ccdd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR61830. +! +! Contributed by Salvatore Filippone +! +module foo_base_mod + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer :: nl=-1 + end type foo_desc_type + +contains + + subroutine foo_cdall(map,nl) + type(foo_desc_type) :: map + integer, optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + + subroutine foo_cdasb(map,info) + integer :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) then + write(0,*) 'Scalar deallocation' + deallocate(this%v) + end if + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + write(0,*) 'Deallocate class() component' + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer, parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer ,save :: NumMy_xy_planes + integer ,parameter :: NumGlobalElements = nx*ny*nz + integer ,parameter :: NumGlobal_xy_planes = nz, & + & Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(NumMyElements) + integer :: NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(map,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field() result(this) + type(scalar_field) :: this + real(foo_dpk_) ,allocatable :: f_v(:) + integer :: i,j,k,NumMyElements, iam, np, info,ip + integer, allocatable :: idxs(:) + + NumMy_xy_planes = NumGlobal_xy_planes + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(NumMyElements) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer ::info + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod + implicit none + type vector_field + type(scalar_field) :: u(1) + end type vector_field +contains + function new_vector_field() result(this) + type(vector_field) :: this + integer :: i + do i=1, size(this%u) + associate(sf=>this%u(i)) + sf = new_scalar_field() + end associate + end do + end function + + subroutine free_v_field(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + call vf(i)%free() + end do + end associate + end subroutine free_v_field + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod + use foo_scalar_field_mod + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer :: iam, np, i,info + + u = new_vector_field() + call foo_geall(v,map,info) + call free_v_field(u) + do i=1,10 + u = new_vector_field() + call free_v_field(u) + av = v%get_vect() + end do +! This gets rid of the "memory leak" + if (associated (u%u(1)%map)) deallocate (u%u(1)%map) + call free_v_field(u) + call v%free() + deallocate(av) +end program +! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }