gcc/testsuite/gfortran.dg/select_type_18.f03

   1 ! { dg-do compile }
   2
   3 ! PR fortran/45783
   4 ! PR fortran/45795
   5 ! This used to fail because of incorrect compile-time typespec on the
   6 ! SELECT TYPE selector.
   7
   8 ! This is the test-case from PR 45795.
   9 ! Contributed by Salvatore Filippone, sfilippone@uniroma2.it.
  10
  11 module base_mod
  12
  13   type  :: base
  14     integer     :: m, n
  15   end type base
  16
  17 end module base_mod
  18
  19 module s_base_mod
  20
  21   use base_mod
  22
  23   type, extends(base) :: s_base
  24   contains
  25     procedure, pass(a) :: cp_to_foo   => s_base_cp_to_foo
  26
  27   end type s_base
  28
  29
  30   type, extends(s_base) :: s_foo
  31
  32     integer              :: nnz
  33     integer, allocatable :: ia(:), ja(:)
  34     real, allocatable :: val(:)
  35
  36   contains
  37
  38     procedure, pass(a) :: cp_to_foo    => s_cp_foo_to_foo
  39
  40   end type s_foo
  41
  42
  43   interface
  44     subroutine s_base_cp_to_foo(a,b,info)
  45       import :: s_base, s_foo
  46       class(s_base), intent(in) :: a
  47       class(s_foo), intent(inout) :: b
  48       integer, intent(out)            :: info
  49     end subroutine s_base_cp_to_foo
  50   end interface
  51
  52   interface
  53     subroutine s_cp_foo_to_foo(a,b,info)
  54       import :: s_foo
  55       class(s_foo), intent(in) :: a
  56       class(s_foo), intent(inout) :: b
  57       integer, intent(out)            :: info
  58     end subroutine s_cp_foo_to_foo
  59   end interface
  60
  61 end module s_base_mod
  62
  63
  64 subroutine trans2(a,b)
  65   use s_base_mod
  66   implicit none
  67
  68   class(s_base), intent(out) :: a
  69   class(base), intent(in)   :: b
  70
  71   type(s_foo) :: tmp
  72   integer err_act, info
  73
  74
  75   info = 0
  76   select type(b)
  77   class is (s_base)
  78     call b%cp_to_foo(tmp,info)
  79   class default
  80     info = -1
  81     write(*,*) 'Invalid dynamic type'
  82   end select
  83
  84   if (info /= 0) write(*,*) 'Error code ',info
  85
  86   return
  87
  88 end subroutine trans2