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 and EXTENDS_TYPE_OF.
   7
   8 implicit none
   9 type t1
  10   integer :: a
  11 end type t1
  12 type, extends(t1):: t11
  13   integer :: b
  14 end type t11
  15 type, extends(t11):: t111
  16   integer :: c
  17 end type t111
  18 type t2
  19   integer :: a
  20 end type t2
  21
  22 type(t1) a1
  23 type(t11) a11
  24 type(t2) a2
  25 class(t1), allocatable :: b1
  26 class(t11), allocatable :: b11
  27 class(t2), allocatable :: b2
  28
  29 logical, parameter :: p1 = same_type_as(a1,a2)  ! F
  30 logical, parameter :: p2 = same_type_as(a2,a1)  ! F
  31 logical, parameter :: p3 = same_type_as(a1,a11) ! F
  32 logical, parameter :: p4 = same_type_as(a11,a1) ! F
  33 logical, parameter :: p5 = same_type_as(a11,a11)! T
  34 logical, parameter :: p6 = same_type_as(a1,a1)  ! T
  35
  36 if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist()
  37
  38 if (same_type_as(b1,b1)   .neqv. .true.) 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
  53 ! .true. -> same type
  54 if (extends_type_of(a1,a1)   .neqv. .true.) call should_not_exist()
  55 if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist()
  56 if (extends_type_of(a2,a2)   .neqv. .true.) call should_not_exist()
  57
  58 ! .false. -> type compatibility possible
  59 if (extends_type_of(a1,a2)  .neqv. .false.) call should_not_exist()
  60 if (extends_type_of(a2,a1)  .neqv. .false.) call should_not_exist()
  61 if (extends_type_of(a11,a2) .neqv. .false.) call should_not_exist()
  62 if (extends_type_of(a2,a11) .neqv. .false.) call should_not_exist()
  63
  64 if (extends_type_of(b1,b2)  .neqv. .false.) call should_not_exist()
  65 if (extends_type_of(b2,b1)  .neqv. .false.) call should_not_exist()
  66 if (extends_type_of(b11,b2) .neqv. .false.) call should_not_exist()
  67 if (extends_type_of(b2,b11) .neqv. .false.) call should_not_exist()
  68
  69 if (extends_type_of(b1,a2)  .neqv. .false.) call should_not_exist()
  70 if (extends_type_of(b2,a1)  .neqv. .false.) call should_not_exist()
  71 if (extends_type_of(b11,a2) .neqv. .false.) call should_not_exist()
  72 if (extends_type_of(b2,a11) .neqv. .false.) call should_not_exist()
  73
  74 if (extends_type_of(a1,b2)  .neqv. .false.) call should_not_exist()
  75 if (extends_type_of(a2,b1)  .neqv. .false.) call should_not_exist()
  76 if (extends_type_of(a11,b2) .neqv. .false.) call should_not_exist()
  77 if (extends_type_of(a2,b11) .neqv. .false.) call should_not_exist()
  78
  79 ! type extension possible, compile-time checkable
  80 if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist()
  81 if (extends_type_of(a11,a1) .neqv. .true.) 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
  87 if (extends_type_of(a1,b11)  .neqv. .false.) call should_not_exist()
  88
  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()
  96 if (extends_type_of(a11,b11) .neqv. .true.) call abort()
  97
  98 allocate(t11 :: b11)
  99 if (extends_type_of(a11,b11) .neqv. .true.) call abort()
 100 deallocate(b11)
 101
 102 allocate(t111 :: b11)
 103 if (extends_type_of(a11,b11) .neqv. .false.) call abort()
 104 deallocate(b11)
 105
 106 allocate(t11 :: b1)
 107 if (extends_type_of(a11,b1) .neqv. .true.) call abort()
 108 deallocate(b1)
 109
 110 allocate(t11::b1)
 111 if (extends_type_of(b1,a11) .neqv. .true.) call abort()
 112 deallocate(b1)
 113
 114 allocate(b1,source=a11)
 115 if (extends_type_of(b1,a11) .neqv. .true.) call abort()
 116 deallocate(b1)
 117
 118 allocate( b1,source=a1)
 119 if (extends_type_of(b1,a11) .neqv. .false.) call abort()
 120 deallocate(b1)
 121
 122 end
 123
 124 ! { dg-final { scan-tree-dump-times "abort" 16 "original" } }
 125 ! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } }