1! { dg-do compile }
2! { dg-options "-fdump-tree-original" }
3!
4! PR fortran/41580
5!
6! Compile-time simplification of SAME_TYPE_AS
7! and EXTENDS_TYPE_OF.
8!
9
10implicit none
11type t1
12  integer :: a
13end type t1
14type, extends(t1):: t11
15  integer :: b
16end type t11
17type, extends(t11):: t111
18  integer :: c
19end type t111
20type t2
21  integer :: a
22end type t2
23
24type(t1) a1
25type(t11) a11
26type(t2) a2
27class(t1), allocatable :: b1
28class(t11), allocatable :: b11
29class(t2), allocatable :: b2
30
31logical, parameter :: p1 = same_type_as(a1,a2)  ! F
32logical, parameter :: p2 = same_type_as(a2,a1)  ! F
33logical, parameter :: p3 = same_type_as(a1,a11) ! F
34logical, parameter :: p4 = same_type_as(a11,a1) ! F
35logical, parameter :: p5 = same_type_as(a11,a11)! T
36logical, parameter :: p6 = same_type_as(a1,a1)  ! T
37
38if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist()
39
40! Not (trivially) compile-time simplifiable:
41if (same_type_as(b1,a1)  .neqv. .true.) call abort()
42if (same_type_as(b1,a11) .neqv. .false.) call abort()
43allocate(t1 :: b1)
44if (same_type_as(b1,a1)  .neqv. .true.) call abort()
45if (same_type_as(b1,a11) .neqv. .false.) call abort()
46deallocate(b1)
47allocate(t11 :: b1)
48if (same_type_as(b1,a1)  .neqv. .false.) call abort()
49if (same_type_as(b1,a11) .neqv. .true.) call abort()
50deallocate(b1)
51
52! .true. -> same type
53if (extends_type_of(a1,a1)   .neqv. .true.) call should_not_exist()
54if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist()
55if (extends_type_of(a2,a2)   .neqv. .true.) call should_not_exist()
56
57! .false. -> type compatibility possible
58if (extends_type_of(a1,a2)  .neqv. .false.) call should_not_exist()
59if (extends_type_of(a2,a1)  .neqv. .false.) call should_not_exist()
60if (extends_type_of(a11,a2) .neqv. .false.) call should_not_exist()
61if (extends_type_of(a2,a11) .neqv. .false.) call should_not_exist()
62
63if (extends_type_of(b1,b2)  .neqv. .false.) call should_not_exist()
64if (extends_type_of(b2,b1)  .neqv. .false.) call should_not_exist()
65if (extends_type_of(b11,b2) .neqv. .false.) call should_not_exist()
66if (extends_type_of(b2,b11) .neqv. .false.) call should_not_exist()
67
68if (extends_type_of(b1,a2)  .neqv. .false.) call should_not_exist()
69if (extends_type_of(b2,a1)  .neqv. .false.) call should_not_exist()
70if (extends_type_of(b11,a2) .neqv. .false.) call should_not_exist()
71if (extends_type_of(b2,a11) .neqv. .false.) call should_not_exist()
72
73if (extends_type_of(a1,b2)  .neqv. .false.) call should_not_exist()
74if (extends_type_of(a2,b1)  .neqv. .false.) call should_not_exist()
75if (extends_type_of(a11,b2) .neqv. .false.) call should_not_exist()
76if (extends_type_of(a2,b11) .neqv. .false.) call should_not_exist()
77
78! type extension possible, compile-time checkable
79if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
80if (extends_type_of(a11,a1) .neqv. .true.) call should_not_exist()
81if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
82
83if (extends_type_of(b1,a1)   .neqv. .true.) call should_not_exist()
84if (extends_type_of(b11,a1)  .neqv. .true.) call should_not_exist()
85if (extends_type_of(b11,a11) .neqv. .true.) call should_not_exist()
86if (extends_type_of(b1,a11)  .neqv. .false.) call should_not_exist()
87
88if (extends_type_of(a1,b11)  .neqv. .false.) call abort()
89
90! Special case, simplified at tree folding:
91if (extends_type_of(b1,b1)   .neqv. .true.) call abort()
92
93! All other possibilities are not compile-time checkable
94if (extends_type_of(b11,b1)  .neqv. .true.) call abort()
95!if (extends_type_of(b1,b11)  .neqv. .false.) call abort() ! FAILS due to PR 47189
96if (extends_type_of(a11,b11) .neqv. .true.) call abort()
97allocate(t11 :: b11)
98if (extends_type_of(a11,b11) .neqv. .true.) call abort()
99deallocate(b11)
100allocate(t111 :: b11)
101if (extends_type_of(a11,b11) .neqv. .false.) call abort()
102deallocate(b11)
103allocate(t11 :: b1)
104if (extends_type_of(a11,b1) .neqv. .true.) call abort()
105deallocate(b1)
106
107end
108
109! { dg-final { scan-tree-dump-times "abort" 13 "original" } }
110! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }
111! { dg-final { cleanup-tree-dump "original" } }
112