OSDN Git Service

* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / alloc_comp_constructor_1.f90
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
107 ! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }\r
108 ! { dg-final { cleanup-tree-dump "original" } }\r