gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fdump-tree-original" }
   3 ! Test constructors of derived type with allocatable components (PR 20541).
   4 !
   5 ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
   6 !            and Paul Thomas  <pault@gcc.gnu.org>
   7 !
   8
   9 Program test_constructor
  10
  11     implicit none
  12
  13     type :: thytype
  14         integer(4) :: a(2,2)
  15     end type thytype
  16
  17     type :: mytype
  18         integer(4), allocatable :: a(:, :)
  19         type(thytype), allocatable :: q(:)
  20     end type mytype
  21
  22     type (mytype) :: x
  23     type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
  24     integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
  25     integer, allocatable :: yy(:,:)
  26     type (thytype), allocatable :: bar(:)
  27     integer :: i
  28
  29     ! Check that null() works
  30     x = mytype(null(), null())
  31     if (allocated(x%a) .or. allocated(x%q)) call abort()
  32
  33     ! Check that unallocated allocatables work
  34     x = mytype(yy, bar)
  35     if (allocated(x%a) .or. allocated(x%q)) call abort()
  36
  37     ! Check that non-allocatables work
  38     x = mytype(y, [foo, foo])
  39     if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
  40     if (any(lbound(x%a) /= lbound(y))) call abort()
  41     if (any(ubound(x%a) /= ubound(y))) call abort()
  42     if (any(x%a /= y)) call abort()
  43     if (size(x%q) /= 2) call abort()
  44     do i = 1, 2
  45         if (any(x%q(i)%a /= foo%a)) call abort()
  46     end do
  47
  48     ! Check that allocated allocatables work
  49     allocate(yy(size(y,1), size(y,2)))
  50     yy = y
  51     allocate(bar(2))
  52     bar = [foo, foo]
  53     x = mytype(yy, bar)
  54     if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
  55     if (any(x%a /= y)) call abort()
  56     if (size(x%q) /= 2) call abort()
  57     do i = 1, 2
  58         if (any(x%q(i)%a /= foo%a)) call abort()
  59     end do
  60
  61     ! Functions returning arrays
  62     x = mytype(bluhu(), null())
  63     if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
  64     if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
  65
  66     ! Functions returning allocatable arrays
  67     x = mytype(blaha(), null())
  68     if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
  69     if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
  70
  71     ! Check that passing the constructor to a procedure works
  72     call check_mytype (mytype(y, [foo, foo]))
  73
  74 contains
  75
  76     subroutine check_mytype(x)
  77         type(mytype), intent(in) :: x
  78         integer :: i
  79
  80         if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
  81         if (any(lbound(x%a) /= lbound(y))) call abort()
  82         if (any(ubound(x%a) /= ubound(y))) call abort()
  83         if (any(x%a /= y)) call abort()
  84         if (size(x%q) /= 2) call abort()
  85         do i = 1, 2
  86             if (any(x%q(i)%a /= foo%a)) call abort()
  87         end do
  88
  89     end subroutine check_mytype
  90
  91
  92     function bluhu()
  93         integer :: bluhu(2,2)
  94
  95         bluhu = reshape ([41, 98, 54, 76], [2,2])
  96     end function bluhu
  97
  98
  99     function blaha()
 100         integer, allocatable :: blaha(:,:)
 101
 102         allocate(blaha(2,2))
 103         blaha = reshape ([40, 97, 53, 75], [2,2])
 104     end function blaha
 105
 106 end program test_constructor
 107 ! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
 108 ! { dg-final { cleanup-tree-dump "original" } }