gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 !
   4 ! Check some basic functionality of allocatable components, including that they
   5 ! are nullified when created and automatically deallocated when
   6 ! 1. A variable goes out of scope
   7 ! 2. INTENT(OUT) dummies
   8 ! 3. Function results
   9 !
  10 !
  11 ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
  12 !            and Paul Thomas  <pault@gcc.gnu.org>
  13 !
  14 module alloc_m
  15
  16     implicit none
  17
  18     type :: alloc1
  19         real, allocatable :: x(:)
  20     end type alloc1
  21
  22 end module alloc_m
  23
  24
  25 program alloc
  26
  27     use alloc_m
  28
  29     implicit none
  30
  31     type :: alloc2
  32         type(alloc1), allocatable :: a1(:)
  33         integer, allocatable :: a2(:)
  34     end type alloc2
  35
  36     type(alloc2) :: b
  37     integer :: i
  38     type(alloc2), allocatable :: c(:)
  39
  40     if (allocated(b%a2) .OR. allocated(b%a1)) then
  41         write (0, *) 'main - 1'
  42         call abort()
  43     end if
  44
  45     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  46     call allocate_alloc2(b)
  47     call check_alloc2(b)
  48
  49     do i = 1, size(b%a1)
  50         ! 1 call to _gfortran_deallocate
  51         deallocate(b%a1(i)%x)
  52     end do
  53
  54     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  55     call allocate_alloc2(b)
  56
  57     call check_alloc2(return_alloc2())
  58     ! 3 calls to _gfortran_deallocate (function result)
  59
  60     allocate(c(1))
  61     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  62     call allocate_alloc2(c(1))
  63     ! 4 calls to _gfortran_deallocate
  64     deallocate(c)
  65
  66     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
  67
  68 contains
  69
  70     subroutine allocate_alloc2(b)
  71         type(alloc2), intent(out) :: b
  72         integer :: i
  73
  74         if (allocated(b%a2) .OR. allocated(b%a1)) then
  75             write (0, *) 'allocate_alloc2 - 1'
  76             call abort()
  77         end if
  78
  79         allocate (b%a2(3))
  80         b%a2 = [ 1, 2, 3 ]
  81
  82         allocate (b%a1(3))
  83
  84         do i = 1, 3
  85             if (allocated(b%a1(i)%x)) then
  86                 write (0, *) 'allocate_alloc2 - 2', i
  87                 call abort()
  88             end if
  89             allocate (b%a1(i)%x(3))
  90             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
  91         end do
  92
  93     end subroutine allocate_alloc2
  94
  95
  96     type(alloc2) function return_alloc2() result(b)
  97         if (allocated(b%a2) .OR. allocated(b%a1)) then
  98             write (0, *) 'return_alloc2 - 1'
  99             call abort()
 100         end if
 101
 102         allocate (b%a2(3))
 103         b%a2 = [ 1, 2, 3 ]
 104
 105         allocate (b%a1(3))
 106
 107         do i = 1, 3
 108             if (allocated(b%a1(i)%x)) then
 109                 write (0, *) 'return_alloc2 - 2', i
 110                 call abort()
 111             end if
 112             allocate (b%a1(i)%x(3))
 113             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
 114         end do
 115     end function return_alloc2
 116
 117
 118     subroutine check_alloc2(b)
 119         type(alloc2), intent(in) :: b
 120
 121         if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
 122             write (0, *) 'check_alloc2 - 1'
 123             call abort()
 124         end if
 125         if (any(b%a2 /= [ 1, 2, 3 ])) then
 126             write (0, *) 'check_alloc2 - 2'
 127             call abort()
 128         end if
 129         do i = 1, 3
 130             if (.NOT.allocated(b%a1(i)%x)) then
 131                 write (0, *) 'check_alloc2 - 3', i
 132                 call abort()
 133             end if
 134             if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
 135                 write (0, *) 'check_alloc2 - 4', i
 136                 call abort()
 137             end if
 138         end do
 139     end subroutine check_alloc2
 140
 141 end program alloc
 142 ! { dg-final { scan-tree-dump-times "builtin_free" 18 "original" } }
 143 ! { dg-final { cleanup-tree-dump "original" } }
 144 ! { dg-final { cleanup-modules "alloc_m" } }