gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03

   1 ! { dg-do run }
   2 ! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
   3 !
   4 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
   5 !
   6 module const_mod
   7   integer, parameter  :: longndig=12
   8   integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
   9   integer, parameter  :: dpk_ = kind(1.d0)
  10   integer, parameter  :: spk_ = kind(1.e0)
  11 end module const_mod
  12
  13 module base_mat_mod
  14   use const_mod
  15   type  :: base_sparse_mat
  16     integer, private     :: m, n
  17     integer, private     :: state, duplicate
  18     logical, private     :: triangle, unitd, upper, sorted
  19   contains
  20     procedure, pass(a) :: get_nzeros
  21   end type base_sparse_mat
  22   private ::  get_nzeros
  23 contains
  24   function get_nzeros(a) result(res)
  25     implicit none
  26     class(base_sparse_mat), intent(in) :: a
  27     integer :: res
  28     integer :: err_act
  29     character(len=20)  :: name='base_get_nzeros'
  30     logical, parameter :: debug=.false.
  31     res = -1
  32   end function get_nzeros
  33 end module base_mat_mod
  34
  35 module s_base_mat_mod
  36   use base_mat_mod
  37   type, extends(base_sparse_mat) :: s_base_sparse_mat
  38   contains
  39     procedure, pass(a) :: s_scals
  40     procedure, pass(a) :: s_scal
  41     generic, public    :: scal => s_scals, s_scal
  42   end type s_base_sparse_mat
  43   private :: s_scals, s_scal
  44
  45   type, extends(s_base_sparse_mat) :: s_coo_sparse_mat
  46
  47     integer              :: nnz
  48     integer, allocatable :: ia(:), ja(:)
  49     real(spk_), allocatable :: val(:)
  50   contains
  51     procedure, pass(a) :: get_nzeros => s_coo_get_nzeros
  52     procedure, pass(a) :: s_scals => s_coo_scals
  53     procedure, pass(a) :: s_scal => s_coo_scal
  54   end type s_coo_sparse_mat
  55   private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros
  56 contains
  57   subroutine s_scals(d,a,info)
  58     implicit none
  59     class(s_base_sparse_mat), intent(in) :: a
  60     real(spk_), intent(in)      :: d
  61     integer, intent(out)            :: info
  62
  63     Integer :: err_act
  64     character(len=20)  :: name='s_scals'
  65     logical, parameter :: debug=.false.
  66
  67     ! This is the base version. If we get here
  68     ! it means the derived class is incomplete,
  69     ! so we throw an error.
  70     info = 700
  71   end subroutine s_scals
  72
  73
  74   subroutine s_scal(d,a,info)
  75     implicit none
  76     class(s_base_sparse_mat), intent(in) :: a
  77     real(spk_), intent(in)      :: d(:)
  78     integer, intent(out)            :: info
  79
  80     Integer :: err_act
  81     character(len=20)  :: name='s_scal'
  82     logical, parameter :: debug=.false.
  83
  84     ! This is the base version. If we get here
  85     ! it means the derived class is incomplete,
  86     ! so we throw an error.
  87     info = 700
  88   end subroutine s_scal
  89
  90   function s_coo_get_nzeros(a) result(res)
  91     implicit none
  92     class(s_coo_sparse_mat), intent(in) :: a
  93     integer :: res
  94     res  = a%nnz
  95   end function s_coo_get_nzeros
  96
  97
  98   subroutine s_coo_scal(d,a,info)
  99     use const_mod
 100     implicit none
 101     class(s_coo_sparse_mat), intent(inout) :: a
 102     real(spk_), intent(in)      :: d(:)
 103     integer, intent(out)            :: info
 104
 105     Integer :: err_act,mnm, i, j, m
 106     character(len=20)  :: name='scal'
 107     logical, parameter :: debug=.false.
 108     info  = 0
 109     do i=1,a%get_nzeros()
 110       j        = a%ia(i)
 111       a%val(i) = a%val(i) * d(j)
 112     enddo
 113   end subroutine s_coo_scal
 114
 115   subroutine s_coo_scals(d,a,info)
 116     use const_mod
 117     implicit none
 118     class(s_coo_sparse_mat), intent(inout) :: a
 119     real(spk_), intent(in)      :: d
 120     integer, intent(out)            :: info
 121
 122     Integer :: err_act,mnm, i, j, m
 123     character(len=20)  :: name='scal'
 124     logical, parameter :: debug=.false.
 125
 126     info  = 0
 127     do i=1,a%get_nzeros()
 128       a%val(i) = a%val(i) * d
 129     enddo
 130   end subroutine s_coo_scals
 131 end module s_base_mat_mod
 132
 133 module s_mat_mod
 134   use s_base_mat_mod
 135   type :: s_sparse_mat
 136     class(s_base_sparse_mat), pointer  :: a
 137   contains
 138     procedure, pass(a) :: s_scals
 139     procedure, pass(a) :: s_scal
 140     generic, public    :: scal => s_scals, s_scal
 141   end type s_sparse_mat
 142   interface scal
 143     module procedure s_scals, s_scal
 144   end interface
 145 contains
 146   subroutine s_scal(d,a,info)
 147     use const_mod
 148     implicit none
 149     class(s_sparse_mat), intent(inout) :: a
 150     real(spk_), intent(in)              :: d(:)
 151     integer, intent(out)                    :: info
 152     integer :: err_act
 153     character(len=20)  :: name='csnmi'
 154     logical, parameter :: debug=.false.
 155     print *, "s_scal"
 156     call a%a%scal(d,info)
 157     return
 158   end subroutine s_scal
 159
 160   subroutine s_scals(d,a,info)
 161     use const_mod
 162     implicit none
 163     class(s_sparse_mat), intent(inout) :: a
 164     real(spk_), intent(in)              :: d
 165     integer, intent(out)                    :: info
 166     integer :: err_act
 167     character(len=20)  :: name='csnmi'
 168     logical, parameter :: debug=.false.
 169 !    print *, "s_scals"
 170     info = 0
 171     call a%a%scal(d,info)
 172     return
 173   end subroutine s_scals
 174 end module s_mat_mod
 175
 176     use s_mat_mod
 177     class (s_sparse_mat), pointer :: a
 178     type (s_sparse_mat), target :: b
 179     type (s_base_sparse_mat), target :: c
 180     integer info
 181     b%a => c
 182     a => b
 183     call a%scal (1.0_spk_, info)
 184     if (info .ne. 700) call abort
 185 end
 186 ! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }
 187