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