gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03

   1 ! { dg-do run }
   2 ! Tests dynamic dispatch of class subroutines.
   3 !
   4 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
   5 !
   6 module m
   7   type :: t1
   8     integer :: i = 42
   9     procedure(make_real), pointer :: ptr
  10   contains
  11     procedure, pass :: real => make_real
  12     procedure, pass :: make_integer
  13     procedure, pass :: prod => i_m_j
  14     generic, public :: extract => real, make_integer
  15     generic, public :: base_extract => real, make_integer
  16   end type t1
  17
  18   type, extends(t1) :: t2
  19     integer :: j = 99
  20   contains
  21     procedure, pass :: real => make_real2
  22     procedure, pass :: make_integer_2
  23     procedure, pass :: prod => i_m_j_2
  24     generic, public :: extract => real, make_integer_2
  25   end type t2
  26 contains
  27   subroutine make_real (arg, arg2)
  28     class(t1), intent(in) :: arg
  29     real :: arg2
  30     arg2 = real (arg%i)
  31   end subroutine make_real
  32
  33   subroutine make_real2 (arg, arg2)
  34     class(t2), intent(in) :: arg
  35     real :: arg2
  36     arg2 = real (arg%j)
  37   end subroutine make_real2
  38
  39   subroutine make_integer (arg, arg2, arg3)
  40     class(t1), intent(in) :: arg
  41     integer :: arg2, arg3
  42     arg3 = arg%i * arg2
  43   end subroutine make_integer
  44
  45   subroutine make_integer_2 (arg, arg2, arg3)
  46     class(t2), intent(in) :: arg
  47     integer :: arg2, arg3
  48     arg3 = arg%j * arg2
  49   end subroutine make_integer_2
  50
  51   subroutine i_m_j (arg, arg2)
  52     class(t1), intent(in) :: arg
  53     integer :: arg2
  54         arg2 = arg%i
  55   end subroutine i_m_j
  56
  57   subroutine i_m_j_2 (arg, arg2)
  58     class(t2), intent(in) :: arg
  59     integer :: arg2
  60         arg2 = arg%j
  61   end subroutine i_m_j_2
  62 end module m
  63
  64   use m
  65   type, extends(t1) :: l1
  66     character(16) :: chr
  67   end type l1
  68   class(t1), pointer :: a !=> NULL()
  69   type(t1), target :: b
  70   type(t2), target :: c
  71   type(l1), target :: d
  72   real :: r
  73   integer :: i
  74
  75   a => b                                   ! declared type
  76   call a%real(r)
  77   if (r .ne. real (42)) call abort
  78   call a%prod(i)
  79   if (i .ne. 42) call abort
  80   call a%extract (2, i)
  81   if (i .ne. 84) call abort
  82   call a%base_extract (2, i)
  83   if (i .ne. 84) call abort
  84
  85   a => c                                   ! extension in module
  86   call a%real(r)
  87   if (r .ne. real (99)) call abort
  88   call a%prod(i)
  89   if (i .ne. 99) call abort
  90   call a%extract (3, i)
  91   if (i .ne. 297) call abort
  92   call a%base_extract (3, i)
  93   if (i .ne. 126) call abort
  94
  95   a => d                                   ! extension in main
  96   call a%real(r)
  97   if (r .ne. real (42)) call abort
  98   call a%prod(i)
  99   if (i .ne. 42) call abort
 100   call a%extract (4, i)
 101   if (i .ne. 168) call abort
 102   call a%extract (4, i)
 103   if (i .ne. 168) call abort
 104 end
 105 ! { dg-final { cleanup-modules "m" } }