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
9Program 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 (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
23    integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
24
25  BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd
26
27    type (mytype) :: x
28    integer, allocatable :: yy(:,:)
29    type (thytype), allocatable :: bar(:)
30    integer :: i
31
32    ! Check that null() works
33    x = mytype(null(), null())
34    if (allocated(x%a) .or. allocated(x%q)) call abort()
35
36    ! Check that unallocated allocatables work
37    x = mytype(yy, bar)
38    if (allocated(x%a) .or. allocated(x%q)) call abort()
39
40    ! Check that non-allocatables work
41    x = mytype(y, [foo, foo])
42    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
43    if (any(lbound(x%a) /= lbound(y))) call abort()
44    if (any(ubound(x%a) /= ubound(y))) call abort()
45    if (any(x%a /= y)) call abort()
46    if (size(x%q) /= 2) call abort()
47    do i = 1, 2
48        if (any(x%q(i)%a /= foo%a)) call abort()
49    end do
50
51    ! Check that allocated allocatables work
52    allocate(yy(size(y,1), size(y,2)))
53    yy = y
54    allocate(bar(2))
55    bar = [foo, foo]
56    x = mytype(yy, bar)
57    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
58    if (any(x%a /= y)) call abort()
59    if (size(x%q) /= 2) call abort()
60    do i = 1, 2
61        if (any(x%q(i)%a /= foo%a)) call abort()
62    end do
63
64    ! Functions returning arrays
65    x = mytype(bluhu(), null())
66    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
67    if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
68
69    ! Functions returning allocatable arrays
70    x = mytype(blaha(), null())
71    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
72    if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
73
74    ! Check that passing the constructor to a procedure works
75    call check_mytype (mytype(y, [foo, foo]))
76  END BLOCK
77contains
78
79    subroutine check_mytype(x)
80        type(mytype), intent(in) :: x
81        integer :: i
82
83        if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
84        if (any(lbound(x%a) /= lbound(y))) call abort()
85        if (any(ubound(x%a) /= ubound(y))) call abort()
86        if (any(x%a /= y)) call abort()
87        if (size(x%q) /= 2) call abort()
88        do i = 1, 2
89            if (any(x%q(i)%a /= foo%a)) call abort()
90        end do
91
92    end subroutine check_mytype
93
94
95    function bluhu()
96        integer :: bluhu(2,2)
97
98        bluhu = reshape ([41, 98, 54, 76], [2,2])
99    end function bluhu
100
101
102    function blaha()
103        integer, allocatable :: blaha(:,:)
104
105        allocate(blaha(2,2))
106        blaha = reshape ([40, 97, 53, 75], [2,2])
107    end function blaha
108
109end program test_constructor
110! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }
111! { dg-final { cleanup-tree-dump "original" } }
112