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     integer :: i
  37
  38   BLOCK  ! To ensure that the allocatables are freed at the end of the scope
  39     type(alloc2) :: b
  40     type(alloc2), allocatable :: c(:)
  41
  42     if (allocated(b%a2) .OR. allocated(b%a1)) then
  43         write (0, *) 'main - 1'
  44         call abort()
  45     end if
  46
  47     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  48     call allocate_alloc2(b)
  49     call check_alloc2(b)
  50
  51     do i = 1, size(b%a1)
  52         ! 1 call to _gfortran_deallocate
  53         deallocate(b%a1(i)%x)
  54     end do
  55
  56     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  57     call allocate_alloc2(b)
  58
  59     call check_alloc2(return_alloc2())
  60     ! 3 calls to _gfortran_deallocate (function result)
  61
  62     allocate(c(1))
  63     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
  64     call allocate_alloc2(c(1))
  65     ! 4 calls to _gfortran_deallocate
  66     deallocate(c)
  67
  68     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
  69   END BLOCK
  70 contains
  71
  72     subroutine allocate_alloc2(b)
  73         type(alloc2), intent(out) :: b
  74         integer :: i
  75
  76         if (allocated(b%a2) .OR. allocated(b%a1)) then
  77             write (0, *) 'allocate_alloc2 - 1'
  78             call abort()
  79         end if
  80
  81         allocate (b%a2(3))
  82         b%a2 = [ 1, 2, 3 ]
  83
  84         allocate (b%a1(3))
  85
  86         do i = 1, 3
  87             if (allocated(b%a1(i)%x)) then
  88                 write (0, *) 'allocate_alloc2 - 2', i
  89                 call abort()
  90             end if
  91             allocate (b%a1(i)%x(3))
  92             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
  93         end do
  94
  95     end subroutine allocate_alloc2
  96
  97
  98     type(alloc2) function return_alloc2() result(b)
  99         if (allocated(b%a2) .OR. allocated(b%a1)) then
 100             write (0, *) 'return_alloc2 - 1'
 101             call abort()
 102         end if
 103
 104         allocate (b%a2(3))
 105         b%a2 = [ 1, 2, 3 ]
 106
 107         allocate (b%a1(3))
 108
 109         do i = 1, 3
 110             if (allocated(b%a1(i)%x)) then
 111                 write (0, *) 'return_alloc2 - 2', i
 112                 call abort()
 113             end if
 114             allocate (b%a1(i)%x(3))
 115             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
 116         end do
 117     end function return_alloc2
 118
 119
 120     subroutine check_alloc2(b)
 121         type(alloc2), intent(in) :: b
 122
 123         if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
 124             write (0, *) 'check_alloc2 - 1'
 125             call abort()
 126         end if
 127         if (any(b%a2 /= [ 1, 2, 3 ])) then
 128             write (0, *) 'check_alloc2 - 2'
 129             call abort()
 130         end if
 131         do i = 1, 3
 132             if (.NOT.allocated(b%a1(i)%x)) then
 133                 write (0, *) 'check_alloc2 - 3', i
 134                 call abort()
 135             end if
 136             if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
 137                 write (0, *) 'check_alloc2 - 4', i
 138                 call abort()
 139             end if
 140         end do
 141     end subroutine check_alloc2
 142
 143 end program alloc
 144 ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }