gcc/testsuite/gfortran.dg/select_type_15.f03

   1 ! { dg-do run }
   2 !
   3 ! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause
   4 !
   5 ! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
   6
   7
   8 module base_mat_mod
   9
  10  type  :: base_sparse_mat
  11  contains
  12    procedure, pass(a) :: get_fmt => base_get_fmt
  13  end type base_sparse_mat
  14
  15 contains
  16
  17  function base_get_fmt(a) result(res)
  18    implicit none
  19    class(base_sparse_mat), intent(in) :: a
  20    character(len=5) :: res
  21    res = 'NULL'
  22  end function base_get_fmt
  23
  24 end module base_mat_mod
  25
  26
  27 module d_base_mat_mod
  28
  29  use base_mat_mod
  30
  31  type, extends(base_sparse_mat) :: d_base_sparse_mat
  32  contains
  33    procedure, pass(a) :: get_fmt => d_base_get_fmt
  34  end type d_base_sparse_mat
  35
  36  type, extends(d_base_sparse_mat) :: x_base_sparse_mat
  37  contains
  38    procedure, pass(a) :: get_fmt => x_base_get_fmt
  39  end type x_base_sparse_mat
  40
  41 contains
  42
  43  function d_base_get_fmt(a) result(res)
  44    implicit none
  45    class(d_base_sparse_mat), intent(in) :: a
  46    character(len=5) :: res
  47    res = 'DBASE'
  48  end function d_base_get_fmt
  49
  50  function x_base_get_fmt(a) result(res)
  51    implicit none
  52    class(x_base_sparse_mat), intent(in) :: a
  53    character(len=5) :: res
  54    res = 'XBASE'
  55  end function x_base_get_fmt
  56
  57 end module d_base_mat_mod
  58
  59
  60 program bug20
  61   use d_base_mat_mod
  62   class(d_base_sparse_mat), allocatable  :: a
  63
  64   allocate(x_base_sparse_mat :: a)
  65   if (a%get_fmt()/="XBASE") STOP 1
  66
  67   select type(a)
  68   type is (d_base_sparse_mat)
  69     STOP 2
  70   class default
  71     if (a%get_fmt()/="XBASE") STOP 3
  72   end select
  73
  74 end program bug20