2014-04-15 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / testsuite / gfortran.dg / class_allocate_1.f03
blob67c8065794bf5493fa71b01dfb878321e49d8f5c
1 ! { dg-do run }
3 ! Allocating CLASS variables.
5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
7  implicit none
9  type t1
10    integer :: comp = 5
11    class(t1),pointer :: cc
12  end type
14  type, extends(t1) :: t2
15    integer :: j
16  end type
18  type, extends(t2) :: t3
19    integer :: k
20  end type
22  class(t1),pointer :: cp, cp2
23  type(t2),pointer :: cp3
24  type(t3) :: x
25  integer :: i
28  ! (1) check that vindex is set correctly (for different cases)
30  i = 0
31  allocate(cp)
32  select type (cp)
33  type is (t1)
34    i = 1
35  type is (t2)
36    i = 2
37  type is (t3)
38    i = 3
39  end select
40  deallocate(cp)
41  if (i /= 1) call abort()
43  i = 0
44  allocate(t2 :: cp)
45  select type (cp)
46  type is (t1)
47    i = 1
48  type is (t2)
49    i = 2
50  type is (t3)
51    i = 3
52  end select
53  deallocate(cp)
54  if (i /= 2) call abort()
56  i = 0
57  allocate(cp, source = x)
58  select type (cp)
59  type is (t1)
60    i = 1
61  type is (t2)
62    i = 2
63  type is (t3)
64    i = 3
65  end select
66  deallocate(cp)
67  if (i /= 3) call abort()
69  i = 0
70  allocate(t2 :: cp2)
71  allocate(cp, source = cp2)
72  allocate(t2 :: cp3)
73  allocate(cp, source=cp3)
74  select type (cp)
75  type is (t1)
76    i = 1
77  type is (t2)
78    i = 2
79  type is (t3)
80    i = 3
81  end select
82  deallocate(cp)
83  deallocate(cp2)
84  if (i /= 2) call abort()
87  ! (2) check initialization (default initialization vs. SOURCE)
89  allocate(cp)
90  if (cp%comp /= 5) call abort()
91  deallocate(cp)
93  x%comp = 4
94  allocate(cp, source=x)
95  if (cp%comp /= 4) call abort()
96  deallocate(cp)
98 end