! { 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" } }