gcc/testsuite/gfortran.dg/class_allocate_1.f03

   1 ! { dg-do run }
   2 !
   3 ! Allocating CLASS variables.
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7  implicit none
   8
   9  type t1
  10    integer :: comp = 5
  11    class(t1),pointer :: cc
  12  end type
  13
  14  type, extends(t1) :: t2
  15    integer :: j
  16  end type
  17
  18  type, extends(t2) :: t3
  19    integer :: k
  20  end type
  21
  22  class(t1),pointer :: cp, cp2
  23  type(t3) :: x
  24  integer :: i
  25
  26
  27  ! (1) check that vindex is set correctly (for different cases)
  28
  29  i = 0
  30  allocate(cp)
  31  select type (cp)
  32  type is (t1)
  33    i = 1
  34  type is (t2)
  35    i = 2
  36  type is (t3)
  37    i = 3
  38  end select
  39  deallocate(cp)
  40  if (i /= 1) call abort()
  41
  42  i = 0
  43  allocate(t2 :: cp)
  44  select type (cp)
  45  type is (t1)
  46    i = 1
  47  type is (t2)
  48    i = 2
  49  type is (t3)
  50    i = 3
  51  end select
  52  deallocate(cp)
  53  if (i /= 2) call abort()
  54
  55  i = 0
  56  allocate(cp, source = x)
  57  select type (cp)
  58  type is (t1)
  59    i = 1
  60  type is (t2)
  61    i = 2
  62  type is (t3)
  63    i = 3
  64  end select
  65  deallocate(cp)
  66  if (i /= 3) call abort()
  67
  68  i = 0
  69  allocate(t2 :: cp2)
  70  allocate(cp, source = cp2)  ! { dg-warning "not supported yet" }
  71  select type (cp)
  72  type is (t1)
  73    i = 1
  74  type is (t2)
  75    i = 2
  76  type is (t3)
  77    i = 3
  78  end select
  79  deallocate(cp)
  80  deallocate(cp2)
  81  if (i /= 2) call abort()
  82
  83
  84  ! (2) check initialization (default initialization vs. SOURCE)
  85
  86  allocate(cp)
  87  if (cp%comp /= 5) call abort()
  88  deallocate(cp)
  89
  90  x%comp = 4
  91  allocate(cp, source=x)
  92  if (cp%comp /= 4) call abort()
  93  deallocate(cp)
  94
  95 end