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