1! { dg-do run }
2!
3! executing SELECT TYPE statements with CLASS IS blocks
4!
5! Contributed by Janus Weil <janus@gcc.gnu.org>
6
7  implicit none
8
9  type :: t1
10    integer :: i
11  end type t1
12
13  type, extends(t1) :: t2
14    integer :: j
15  end type t2
16
17  type, extends(t2) :: t3
18    real :: r
19  end type
20
21  class(t1), pointer :: cp
22  type(t1), target :: a
23  type(t2), target :: b
24  type(t3), target :: c
25  integer :: i
26
27  cp => c
28  i = 0
29  select type (cp)
30  type is (t1)
31    i = 1
32  type is (t2)
33    i = 2
34  class is (t1)
35    i = 3
36  class default
37    i = 4
38  end select
39  print *,i
40  if (i /= 3) call abort()
41
42  cp => a
43  select type (cp)
44  type is (t1)
45    i = 1
46  type is (t2)
47    i = 2
48  class is (t1)
49    i = 3
50  end select
51  print *,i
52  if (i /= 1) call abort()
53
54  cp => b
55  select type (cp)
56  type is (t1)
57    i = 1
58  class is (t3)
59    i = 3
60  class is (t2)
61    i = 4
62  class is (t1)
63    i = 5
64  end select
65  print *,i
66  if (i /= 4) call abort()
67
68  cp => b
69  select type (cp)
70  type is (t1)
71    i = 1
72  class is (t1)
73    i = 5
74  class is (t2)
75    i = 4
76  class is (t3)
77    i = 3
78  end select
79  print *,i
80  if (i /= 4) call abort()
81
82  cp => a
83  select type (cp)
84  type is (t2)
85    i = 1
86  class is (t2)
87    i = 2
88  class default
89    i = 3
90  class is (t3)
91    i = 4
92  type is (t3)
93    i = 5
94  end select
95  print *,i
96  if (i /= 3) call abort()
97
98end
99