alloc_comp_basics_1.f90

来自「用于进行gcc测试」· F90 代码 · 共 145 行

! { 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
!
!
! Contributed by Erik Edelmann  <[e-mail]>
!            and Paul Thomas  <[e-mail]>
!
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 "builtin_free" 27 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "alloc_m" } }