trunk/gcc/testsuite/gfortran.dg/select_type_8.f03

   1 ! { dg-do run }
   2 !
   3 ! executing SELECT TYPE statements with CLASS IS blocks
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7   implicit none
   8
   9   type :: t1
  10     integer :: i
  11   end type t1
  12
  13   type, extends(t1) :: t2
  14     integer :: j
  15   end type t2
  16
  17   type, extends(t2) :: t3
  18     real :: r
  19   end type
  20
  21   class(t1), pointer :: cp
  22   type(t1), target :: a
  23   type(t2), target :: b
  24   type(t3), target :: c
  25   integer :: i
  26
  27   cp => c
  28   i = 0
  29   select type (cp)
  30   type is (t1)
  31     i = 1
  32   type is (t2)
  33     i = 2
  34   class is (t1)
  35     i = 3
  36   class default
  37     i = 4
  38   end select
  39   print *,i
  40   if (i /= 3) call abort()
  41
  42   cp => a
  43   select type (cp)
  44   type is (t1)
  45     i = 1
  46   type is (t2)
  47     i = 2
  48   class is (t1)
  49     i = 3
  50   end select
  51   print *,i
  52   if (i /= 1) call abort()
  53
  54   cp => b
  55   select type (cp)
  56   type is (t1)
  57     i = 1
  58   class is (t3)
  59     i = 3
  60   class is (t2)
  61     i = 4
  62   class is (t1)
  63     i = 5
  64   end select
  65   print *,i
  66   if (i /= 4) call abort()
  67
  68   cp => b
  69   select type (cp)
  70   type is (t1)
  71     i = 1
  72   class is (t1)
  73     i = 5
  74   class is (t2)
  75     i = 4
  76   class is (t3)
  77     i = 3
  78   end select
  79   print *,i
  80   if (i /= 4) call abort()
  81
  82   cp => a
  83   select type (cp)
  84   type is (t2)
  85     i = 1
  86   class is (t2)
  87     i = 2
  88   class default
  89     i = 3
  90   class is (t3)
  91     i = 4
  92   type is (t3)
  93     i = 5
  94   end select
  95   print *,i
  96   if (i /= 3) call abort()
  97
  98 end