------- Comment #9 from paul dot richard dot thomas at cea dot fr 2006-07-12
14:20 -------
Created an attachment (id=11867)
--> (http://gcc.gnu.org/bugzilla/attachment.cgi?id=11867&action=view)
For discussion, perusal and testing: a beta-release of the TR15581 patch
This patch represents some months of work by Erik and myself. It is still not
complete and has at least one residual source of memory leakage (derived type
constructors with function array-valued actuals). That withstanding, it does
most of the memory management required by the standard, it does assignments
correctly and handless allocatable components in contructors. There is still a
way to go before it is submittable but it's getting there!
What does it do?
(i) It runs most of the iso_varying_string testsuite (vst16.f95 fails in io,
vst28.f95, vst30.f95 and vst31.f95 need modification to catch zero length
strings).
(ii) This tests the basic functionality:
! { dg-do run}
! { dg-options "-O2 -fdump-tree-original" }
!
! Check some basic functionality of allocatable components, including that they
! are nullified when created and automatically deallocated when
! 1. A variable goes out of scope
! 2. INTENT(OUT) dummies
! 3. Function results
!
module alloc_m
implicit none
type :: alloc1
real, allocatable :: x(:)
end type alloc1
end module alloc_m
program alloc
use alloc_m
implicit none
type :: alloc2
type(alloc1), allocatable :: a1(:)
integer, allocatable :: a2(:)
end type alloc2
type(alloc2) :: b
integer :: i
type(alloc2), allocatable :: c(:)
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'main - 1'
call abort()
end if
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(b)
call check_alloc2(b)
do i = 1, size(b%a1)
! 1 call to _gfortran_deallocate
deallocate(b%a1(i)%x)
end do
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(b)
call check_alloc2(return_alloc2())
! 3 calls to _gfortran_deallocate (function result)
allocate(c(1))
! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
call allocate_alloc2(c(1))
! 4 calls to _gfortran_deallocate
deallocate(c)
! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
contains
subroutine allocate_alloc2(b)
type(alloc2), intent(out) :: b
integer :: i
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'allocate_alloc2 - 1'
call abort()
end if
allocate (b%a2(3))
b%a2 = [ 1, 2, 3 ]
allocate (b%a1(3))
do i = 1, 3
if (allocated(b%a1(i)%x)) then
write (0, *) 'allocate_alloc2 - 2', i
call abort()
end if
allocate (b%a1(i)%x(3))
b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
end do
end subroutine allocate_alloc2
type(alloc2) function return_alloc2() result(b)
if (allocated(b%a2) .OR. allocated(b%a1)) then
write (0, *) 'return_alloc2 - 1'
call abort()
end if
allocate (b%a2(3))
b%a2 = [ 1, 2, 3 ]
allocate (b%a1(3))
do i = 1, 3
if (allocated(b%a1(i)%x)) then
write (0, *) 'return_alloc2 - 2', i
call abort()
end if
allocate (b%a1(i)%x(3))
b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
end do
end function return_alloc2
subroutine check_alloc2(b)
type(alloc2), intent(in) :: b
if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
write (0, *) 'check_alloc2 - 1'
call abort()
end if
if (any(b%a2 /= [ 1, 2, 3 ])) then
write (0, *) 'check_alloc2 - 2'
call abort()
end if
do i = 1, 3
if (.NOT.allocated(b%a1(i)%x)) then
write (0, *) 'check_alloc2 - 3', i
call abort()
end if
if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
write (0, *) 'check_alloc2 - 4', i
call abort()
end if
end do
end subroutine check_alloc2
end program alloc
! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
(iii) The following tests constructors:
program
type :: mytype
integer, allocatable :: a(:, :)
end type mytype
type (mytype) :: x
integer :: y(0:1, -1:0) = reshape ((/42, 99, 55, 77/), (/2,2/))
x = mytype (y)
call foo (x, y)
x = mytype (reshape ((/42, 99, 55, 77/), (/2,2/)))
call foo (x, reshape ((/42, 99, 55, 77/), (/2,2/)))
x = mytype (bar (y))
call foo (x, y**3)
contains
subroutine foo (x, y)
type(mytype) :: x
integer y(:,:)
if (any (x%a .ne. y)) call abort ()
end subroutine foo
function bar (x)
integer, dimension(:,:) :: x
integer, dimension(size(x, 1), size(x, 2)) :: bar
bar = x**3
end function bar
end program
(iv) Whilst this tests assignments:
type :: ivs
character(1), allocatable :: chars(:)
end type ivs
type(ivs) :: a, b
type(ivs) :: x(3), y(3)
allocate(a%chars(5))
a%chars = (/"h","e","l","l","o"/)
! An intrinsic assignment must deallocate the l-value, copy across the
! array and null the descriptor data field of the r-value.
b = a
if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
if (allocated (a%chars) .neqv. .false.) call abort ()
! Scalar to array needs to copy the derived type, to its ultimate components,
! to each of the l-value elements and then to deallocate the r-value. */
x = b
x(2)%chars = (/"g","'","d","a","y"/)
if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
if (allocated (b%chars) .neqv. .false.) call abort ()
deallocate (x(1)%chars, x(2)%chars)
! Array intrinsic assignments are like their scalar counterpart and
! must deallocate each element of the l-value, copy across the
! arrays from the r-value elements and null the descriptor data field
! of the r-value elements.
allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
x(1)%chars = (/"h","e","l","l","o"/)
x(2)%chars = (/"g","'","d","a","y"/)
x(3)%chars = (/"g","o","d","a","g"/)
y(2:1:-1) = x(1:2)
if (allocated (x(1)%chars) .neqv. .false.) call abort ()
if (allocated (x(2)%chars) .neqv. .false.) call abort ()
if (allocated (x(3)%chars) .neqv. .true.) call abort ()
if (allocated (y(1)%chars) .neqv. .true.) call abort ()
if (allocated (y(2)%chars) .neqv. .true.) call abort ()
if (allocated (y(3)%chars) .neqv. .false.) call abort ()
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
! In the case of an assignment where there is a dependency, so that a
! temporary is necessary, each element must be copied to its destination
! and the source element nullified.
y(2:3) = y(1:2)
if (allocated (y(1)%chars)) call abort ()
if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
end
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=20541
