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   end type t1
  16
  17   type, extends(t1) :: t2
  18     integer :: j = 99
  19   contains
  20     procedure, pass :: real => make_real2
  21     procedure, pass :: make_integer => make_integer_2
  22     procedure, pass :: prod => i_m_j_2
  23   end type t2
  24 contains
  25   subroutine make_real (arg, arg2)
  26     class(t1), intent(in) :: arg
  27     real :: arg2
  28     arg2 = real (arg%i)
  29   end subroutine make_real
  30
  31   subroutine make_real2 (arg, arg2)
  32     class(t2), intent(in) :: arg
  33     real :: arg2
  34     arg2 = real (arg%j)
  35   end subroutine make_real2
  36
  37   subroutine make_integer (arg, arg2, arg3)
  38     class(t1), intent(in) :: arg
  39     integer :: arg2, arg3
  40     arg3 = arg%i * arg2
  41   end subroutine make_integer
  42
  43   subroutine make_integer_2 (arg, arg2, arg3)
  44     class(t2), intent(in) :: arg
  45     integer :: arg2, arg3
  46     arg3 = arg%j * arg2
  47   end subroutine make_integer_2
  48
  49   subroutine i_m_j (arg, arg2)
  50     class(t1), intent(in) :: arg
  51     integer :: arg2
  52         arg2 = arg%i
  53   end subroutine i_m_j
  54
  55   subroutine i_m_j_2 (arg, arg2)
  56     class(t2), intent(in) :: arg
  57     integer :: arg2
  58         arg2 = arg%j
  59   end subroutine i_m_j_2
  60 end module m
  61
  62   use m
  63   type, extends(t1) :: l1
  64     character(16) :: chr
  65   end type l1
  66   class(t1), pointer :: a !=> NULL()
  67   type(t1), target :: b
  68   type(t2), target :: c
  69   type(l1), target :: d
  70   real :: r
  71   integer :: i
  72
  73   a => b                                   ! declared type
  74   call a%real(r)
  75   if (r .ne. real (42)) call abort
  76   call a%prod(i)
  77   if (i .ne. 42) call abort
  78   call a%extract (2, i)
  79   if (i .ne. 84) call abort
  80
  81   a => c                                   ! extension in module
  82   call a%real(r)
  83   if (r .ne. real (99)) call abort
  84   call a%prod(i)
  85   if (i .ne. 99) call abort
  86   call a%extract (3, i)
  87   if (i .ne. 297) call abort
  88
  89   a => d                                   ! extension in main
  90   call a%real(r)
  91   if (r .ne. real (42)) call abort
  92   call a%prod(i)
  93   if (i .ne. 42) call abort
  94   call a%extract (4, i)
  95   if (i .ne. 168) call abort
  96 end