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