+2015-01-25 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <vehre@gcc.gnu.org>
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
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
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;
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);
}
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);
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
+2015-01-25 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <danglin@gcc.gnu.org>
* g++.dg/Wno-frame-address.C: Skip on hppa*-*-*.
--- /dev/null
+! { 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 <mexas@bristol.ac.uk>
+!
+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
--- /dev/null
+! { dg-do compile }
+!
+! Tests the fix for PR61819.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+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
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Tests the fix for PR61830.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+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" } }
projects / gcc.git / commitdiff