Subversion Repositories openrisc

! { dg-do run }

!

! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause

!

! Contributed by Salvatore Filippone 

module base_mat_mod

 type  :: base_sparse_mat

 contains

   procedure, pass(a) :: get_fmt => base_get_fmt

 end type base_sparse_mat

contains

 function base_get_fmt(a) result(res)

   implicit none

   class(base_sparse_mat), intent(in) :: a

   character(len=5) :: res

   res = 'NULL'

 end function base_get_fmt

end module base_mat_mod

module d_base_mat_mod

 use base_mat_mod

 type, extends(base_sparse_mat) :: d_base_sparse_mat

 contains

   procedure, pass(a) :: get_fmt => d_base_get_fmt

 end type d_base_sparse_mat

 type, extends(d_base_sparse_mat) :: x_base_sparse_mat

 contains

   procedure, pass(a) :: get_fmt => x_base_get_fmt

 end type x_base_sparse_mat

contains

 function d_base_get_fmt(a) result(res)

   implicit none

   class(d_base_sparse_mat), intent(in) :: a

   character(len=5) :: res

   res = 'DBASE'

 end function d_base_get_fmt

 function x_base_get_fmt(a) result(res)

   implicit none

   class(x_base_sparse_mat), intent(in) :: a

   character(len=5) :: res

   res = 'XBASE'

 end function x_base_get_fmt

end module d_base_mat_mod

program bug20

  use d_base_mat_mod

  class(d_base_sparse_mat), allocatable  :: a

  allocate(x_base_sparse_mat :: a)

  if (a%get_fmt()/="XBASE") call abort()

  select type(a)

  type is (d_base_sparse_mat)

    call abort()

  class default

    if (a%get_fmt()/="XBASE") call abort()

  end select

end program bug20

! { dg-final { cleanup-modules "base_mat_mod d_base_mat_mod" } }