gcc/testsuite/gfortran.dg/extends_type_of_3.f90

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