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(t2),pointer :: cp3
  24  type(t3) :: x
  25  integer :: i
  26
  27
  28  ! (1) check that vindex is set correctly (for different cases)
  29
  30  i = 0
  31  allocate(cp)
  32  select type (cp)
  33  type is (t1)
  34    i = 1
  35  type is (t2)
  36    i = 2
  37  type is (t3)
  38    i = 3
  39  end select
  40  deallocate(cp)
  41  if (i /= 1) call abort()
  42
  43  i = 0
  44  allocate(t2 :: cp)
  45  select type (cp)
  46  type is (t1)
  47    i = 1
  48  type is (t2)
  49    i = 2
  50  type is (t3)
  51    i = 3
  52  end select
  53  deallocate(cp)
  54  if (i /= 2) call abort()
  55
  56  i = 0
  57  allocate(cp, source = x)
  58  select type (cp)
  59  type is (t1)
  60    i = 1
  61  type is (t2)
  62    i = 2
  63  type is (t3)
  64    i = 3
  65  end select
  66  deallocate(cp)
  67  if (i /= 3) call abort()
  68
  69  i = 0
  70  allocate(t2 :: cp2)
  71  allocate(cp, source = cp2)
  72  allocate(t2 :: cp3)
  73  allocate(cp, source=cp3)
  74  select type (cp)
  75  type is (t1)
  76    i = 1
  77  type is (t2)
  78    i = 2
  79  type is (t3)
  80    i = 3
  81  end select
  82  deallocate(cp)
  83  deallocate(cp2)
  84  if (i /= 2) call abort()
  85
  86
  87  ! (2) check initialization (default initialization vs. SOURCE)
  88
  89  allocate(cp)
  90  if (cp%comp /= 5) call abort()
  91  deallocate(cp)
  92
  93  x%comp = 4
  94  allocate(cp, source=x)
  95  if (cp%comp /= 4) call abort()
  96  deallocate(cp)
  97
  98 end