gcc/testsuite/gfortran.dg/select_type_12.f03

   1 ! { dg-do compile }
   2 !
   3 ! PR 44044: [OOP] SELECT TYPE with class-valued function
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7 implicit none
   8
   9 type :: t1
  10   integer :: i
  11 end type
  12
  13 type, extends(t1) :: t2
  14 end type
  15
  16 type(t1),target :: x1
  17 type(t2),target :: x2
  18
  19 select type ( y => fun(1) )
  20 type is (t1)
  21   print *,"t1"
  22 type is (t2)
  23   print *,"t2"
  24 class default
  25   print *,"default"
  26 end select
  27
  28 select type ( y => fun(-1) )
  29 type is (t1)
  30   print *,"t1"
  31 type is (t2)
  32   print *,"t2"
  33 class default
  34   print *,"default"
  35 end select
  36
  37 contains
  38
  39   function fun(i)
  40     class(t1),pointer :: fun
  41     integer :: i
  42     if (i>0) then
  43       fun => x1
  44     else if (i<0) then
  45       fun => x2
  46     else
  47       fun => NULL()
  48     end if
  49   end function
  50
  51 end